* [PATCH] Modula-2: merge proposal/review: 5/9 05.patch-set-04-2 v2
@ 2022-05-19 13:55 Gaius Mulley
0 siblings, 0 replies; only message in thread
From: Gaius Mulley @ 2022-05-19 13:55 UTC (permalink / raw)
To: gcc-patches
Hello,
this email contains v2 of:
4. the glue code (between Modula-2 and GCC) part 2/3.
(*.{cc,h} files). Comment formatting fixes have been applied
and also it contains a missing file gcc/m2/plugin/m2rte.cc
(the plugin module which utilizes gcc/m2/gm2-gcc/rtegraph.{cc,h}).
-----------------------------
New file: gcc/m2/gm2-gcc/m2statement.cc
-----------------------------
/* m2statement.cc provides an interface to GCC statement trees.
Copyright (C) 2012-2022 Free Software Foundation, Inc.
Contributed by Gaius Mulley <gaius@glam.ac.uk>.
This file is part of GNU Modula-2.
GNU Modula-2 is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 3, or (at your option)
any later version.
GNU Modula-2 is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
General Public License for more details.
You should have received a copy of the GNU General Public License
along with GNU Modula-2; see the file COPYING3. If not see
<http://www.gnu.org/licenses/>. */
#include "gcc-consolidation.h"
#include "../gm2-lang.h"
#include "../m2-tree.h"
/* Prototypes. */
#define m2statement_c
#include "m2assert.h"
#include "m2block.h"
#include "m2convert.h"
#include "m2decl.h"
#include "m2expr.h"
#include "m2statement.h"
#include "m2tree.h"
#include "m2treelib.h"
#include "m2type.h"
static GTY (()) tree param_list = NULL_TREE; /* Ready for the next time we
call/define a function. */
static GTY (()) tree last_function = NULL_TREE;
/* BuildStartFunctionCode - generate function entry code. */
void
m2statement_BuildStartFunctionCode (location_t location, tree fndecl,
int isexported, int isinline)
{
tree param_decl;
ASSERT_BOOL (isexported);
ASSERT_BOOL (isinline);
/* Announce we are compiling this function. */
announce_function (fndecl);
/* Set up to compile the function and enter it. */
DECL_INITIAL (fndecl) = NULL_TREE;
current_function_decl = fndecl;
m2block_pushFunctionScope (fndecl);
m2statement_SetBeginLocation (location);
ASSERT_BOOL ((cfun != NULL));
/* Initialize the RTL code for the function. */
allocate_struct_function (fndecl, false);
/* Begin the statement tree for this function. */
DECL_SAVED_TREE (fndecl) = NULL_TREE;
/* Set the context of these parameters to this function. */
for (param_decl = DECL_ARGUMENTS (fndecl); param_decl;
param_decl = TREE_CHAIN (param_decl))
DECL_CONTEXT (param_decl) = fndecl;
/* This function exists in static storage. (This does not mean
`static' in the C sense!) */
TREE_STATIC (fndecl) = 1;
TREE_PUBLIC (fndecl) = isexported;
TREE_ADDRESSABLE (fndecl) = 1; /* (--fixme-- not sure about this). */
DECL_DECLARED_INLINE_P (fndecl) = 0; /* isinline; */
}
static void
gm2_gimplify_function_node (tree fndecl)
{
/* Convert all nested functions to GIMPLE now. We do things in this
order so that items like VLA sizes are expanded properly in the
context of the correct function. */
struct cgraph_node *cgn;
dump_function (TDI_original, fndecl);
gimplify_function_tree (fndecl);
cgn = cgraph_node::get_create (fndecl);
for (cgn = first_nested_function (cgn);
cgn != NULL; cgn = next_nested_function (cgn))
gm2_gimplify_function_node (cgn->decl);
}
/* BuildEndFunctionCode - generates the function epilogue. */
void
m2statement_BuildEndFunctionCode (location_t location, tree fndecl, int nested)
{
tree block = DECL_INITIAL (fndecl);
BLOCK_SUPERCONTEXT (block) = fndecl;
/* Must mark the RESULT_DECL as being in this function. */
DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;
/* And attach it to the function. */
DECL_INITIAL (fndecl) = block;
m2block_finishFunctionCode (fndecl);
m2statement_SetEndLocation (location);
gm2_genericize (fndecl);
if (nested)
(void)cgraph_node::get_create (fndecl);
else
cgraph_node::finalize_function (fndecl, false);
m2block_popFunctionScope ();
/* We're leaving the context of this function, so zap cfun. It's
still in DECL_STRUCT_FUNCTION, and we'll restore it in
tree_rest_of_compilation. */
set_cfun (NULL);
current_function_decl = NULL;
}
/* BuildPushFunctionContext - pushes the current function context.
Maps onto push_function_context in ../function.cc. */
void
m2statement_BuildPushFunctionContext (void)
{
push_function_context ();
}
/* BuildPopFunctionContext - pops the current function context. Maps
onto pop_function_context in ../function.cc. */
void
m2statement_BuildPopFunctionContext (void)
{
pop_function_context ();
}
void
m2statement_SetBeginLocation (location_t location)
{
if (cfun != NULL)
cfun->function_start_locus = location;
}
void
m2statement_SetEndLocation (location_t location)
{
if (cfun != NULL)
cfun->function_end_locus = location;
}
/* BuildAssignmentTree builds the assignment of, des, and, expr.
It returns, des. */
tree
m2statement_BuildAssignmentTree (location_t location, tree des, tree expr)
{
tree result;
m2assert_AssertLocation (location);
STRIP_TYPE_NOPS (expr);
if (TREE_CODE (expr) == FUNCTION_DECL)
result = build2 (MODIFY_EXPR, TREE_TYPE (des), des,
m2expr_BuildAddr (location, expr, FALSE));
else
{
gcc_assert (TREE_CODE (TREE_TYPE (des)) != TYPE_DECL);
if (TREE_TYPE (expr) == TREE_TYPE (des))
result = build2 (MODIFY_EXPR, TREE_TYPE (des), des, expr);
else
result = build2 (
MODIFY_EXPR, TREE_TYPE (des), des,
m2convert_BuildConvert (location, TREE_TYPE (des), expr, FALSE));
}
TREE_SIDE_EFFECTS (result) = 1;
add_stmt (location, result);
return des;
}
/* BuildAssignmentStatement builds the assignment of, des, and, expr. */
void
m2statement_BuildAssignmentStatement (location_t location, tree des, tree expr)
{
m2statement_BuildAssignmentTree (location, des, expr);
}
/* BuildGoto builds a goto operation. */
void
m2statement_BuildGoto (location_t location, char *name)
{
tree label = m2block_getLabel (location, name);
m2assert_AssertLocation (location);
TREE_USED (label) = 1;
add_stmt (location, build1 (GOTO_EXPR, void_type_node, label));
}
/* DeclareLabel - create a label, name. */
void
m2statement_DeclareLabel (location_t location, char *name)
{
tree label = m2block_getLabel (location, name);
m2assert_AssertLocation (location);
add_stmt (location, build1 (LABEL_EXPR, void_type_node, label));
}
/* BuildParam - build a list of parameters, ready for a subsequent
procedure call. */
void
m2statement_BuildParam (location_t location, tree param)
{
m2assert_AssertLocation (location);
if (TREE_CODE (param) == FUNCTION_DECL)
param = m2expr_BuildAddr (location, param, FALSE);
param_list = chainon (build_tree_list (NULL_TREE, param), param_list);
}
/* nCount - return the number of chained tree nodes in list, t. */
static int
nCount (tree t)
{
int i = 0;
while (t != NULL)
{
i++;
t = TREE_CHAIN (t);
}
return i;
}
/* BuildProcedureCallTree - creates a procedure call from a procedure
and parameter list and the return type, rettype. */
tree
m2statement_BuildProcedureCallTree (location_t location, tree procedure,
tree rettype)
{
tree functype = TREE_TYPE (procedure);
tree funcptr = build1 (ADDR_EXPR, build_pointer_type (functype), procedure);
tree call;
int n = nCount (param_list);
tree *argarray = XALLOCAVEC (tree, n);
tree t = param_list;
int i;
m2assert_AssertLocation (location);
ASSERT_CONDITION (
last_function
== NULL_TREE); /* Previous function value has not been collected. */
TREE_USED (procedure) = TRUE;
for (i = 0; i < n; i++)
{
argarray[i] = TREE_VALUE (t);
t = TREE_CHAIN (t);
}
if (rettype == NULL_TREE)
{
rettype = void_type_node;
call = build_call_array_loc (location, rettype, funcptr, n, argarray);
TREE_USED (call) = TRUE;
TREE_SIDE_EFFECTS (call) = TRUE;
#if defined(DEBUG_PROCEDURE_CALLS)
fprintf (stderr, "built the modula-2 call, here is the tree\n");
fflush (stderr);
debug_tree (call);
#endif
param_list
= NULL_TREE; /* Ready for the next time we call a procedure. */
last_function = NULL_TREE;
return call;
}
else
{
last_function = build_call_array_loc (
location, m2tree_skip_type_decl (rettype), funcptr, n, argarray);
TREE_USED (last_function) = TRUE;
TREE_SIDE_EFFECTS (last_function) = TRUE;
param_list
= NULL_TREE; /* Ready for the next time we call a procedure. */
return last_function;
}
}
/* BuildIndirectProcedureCallTree - creates a procedure call from a
procedure and parameter list and the return type, rettype. */
tree
m2statement_BuildIndirectProcedureCallTree (location_t location,
tree procedure, tree rettype)
{
tree call;
int n = nCount (param_list);
tree *argarray = XALLOCAVEC (tree, n);
tree t = param_list;
int i;
m2assert_AssertLocation (location);
TREE_USED (procedure) = TRUE;
TREE_SIDE_EFFECTS (procedure) = TRUE;
for (i = 0; i < n; i++)
{
argarray[i] = TREE_VALUE (t);
t = TREE_CHAIN (t);
}
if (rettype == NULL_TREE)
{
rettype = void_type_node;
call = build_call_array_loc (location, rettype, procedure, n, argarray);
TREE_USED (call) = TRUE;
TREE_SIDE_EFFECTS (call) = TRUE;
#if defined(DEBUG_PROCEDURE_CALLS)
fprintf (stderr, "built the modula-2 call, here is the tree\n");
fflush (stderr);
debug_tree (call);
#endif
last_function = NULL_TREE;
param_list
= NULL_TREE; /* Ready for the next time we call a procedure. */
return call;
}
else
{
last_function = build_call_array_loc (
location, m2tree_skip_type_decl (rettype), procedure, n, argarray);
TREE_USED (last_function) = TRUE;
TREE_SIDE_EFFECTS (last_function) = TRUE;
param_list
= NULL_TREE; /* Ready for the next time we call a procedure. */
return last_function;
}
}
/* BuildFunctValue - generates code for value :=
last_function(foobar); */
tree
m2statement_BuildFunctValue (location_t location, tree value)
{
tree assign
= m2treelib_build_modify_expr (location, value, NOP_EXPR, last_function);
m2assert_AssertLocation (location);
ASSERT_CONDITION (
last_function
!= NULL_TREE); /* No value available, possible used before. */
TREE_SIDE_EFFECTS (assign) = TRUE;
TREE_USED (assign) = TRUE;
last_function = NULL_TREE;
return assign;
}
/* BuildCall2 - builds a tree representing: function (arg1, arg2). */
tree
m2statement_BuildCall2 (location_t location, tree function, tree rettype,
tree arg1, tree arg2)
{
m2assert_AssertLocation (location);
ASSERT_CONDITION (param_list == NULL_TREE);
param_list = chainon (build_tree_list (NULL_TREE, arg2), param_list);
param_list = chainon (build_tree_list (NULL_TREE, arg1), param_list);
return m2statement_BuildProcedureCallTree (location, function, rettype);
}
/* BuildCall3 - builds a tree representing: function (arg1, arg2,
arg3). */
tree
m2statement_BuildCall3 (location_t location, tree function, tree rettype,
tree arg1, tree arg2, tree arg3)
{
m2assert_AssertLocation (location);
ASSERT_CONDITION (param_list == NULL_TREE);
param_list = chainon (build_tree_list (NULL_TREE, arg3), param_list);
param_list = chainon (build_tree_list (NULL_TREE, arg2), param_list);
param_list = chainon (build_tree_list (NULL_TREE, arg1), param_list);
return m2statement_BuildProcedureCallTree (location, function, rettype);
}
/* BuildFunctionCallTree - creates a procedure function call from
a procedure and parameter list and the return type, rettype.
No tree is returned as the tree is held in the last_function global
variable. It is expected the BuildFunctValue is to be called after
a call to BuildFunctionCallTree. */
void
m2statement_BuildFunctionCallTree (location_t location, tree procedure,
tree rettype)
{
m2statement_BuildProcedureCallTree (location, procedure, rettype);
}
/* SetLastFunction - assigns last_function to, t. */
void
m2statement_SetLastFunction (tree t)
{
last_function = t;
}
/* SetParamList - assigns param_list to, t. */
void
m2statement_SetParamList (tree t)
{
param_list = t;
}
/* GetLastFunction - returns, last_function. */
tree
m2statement_GetLastFunction (void)
{
return last_function;
}
/* GetParamList - returns, param_list. */
tree
m2statement_GetParamList (void)
{
return param_list;
}
/* GetCurrentFunction - returns the current_function. */
tree
m2statement_GetCurrentFunction (void)
{
return current_function_decl;
}
/* GetParamTree - return parameter, i. */
tree
m2statement_GetParamTree (tree call, unsigned int i)
{
return CALL_EXPR_ARG (call, i);
}
/* BuildTryFinally - returns a TRY_FINALL_EXPR with the call and
cleanups attached. */
tree
m2statement_BuildTryFinally (location_t location, tree call, tree cleanups)
{
return build_stmt (location, TRY_FINALLY_EXPR, call, cleanups);
}
/* BuildCleanUp - return a CLEANUP_POINT_EXPR which will clobber,
param. */
tree
m2statement_BuildCleanUp (tree param)
{
tree clobber = build_constructor (TREE_TYPE (param), NULL);
TREE_THIS_VOLATILE (clobber) = 1;
return build2 (MODIFY_EXPR, TREE_TYPE (param), param, clobber);
}
/* BuildAsm - generates an inline assembler instruction. */
void
m2statement_BuildAsm (location_t location, tree instr, int isVolatile,
int isSimple, tree inputs, tree outputs, tree trash,
tree labels)
{
tree string = resolve_asm_operand_names (instr, outputs, inputs, labels);
tree args = build_stmt (location, ASM_EXPR, string, outputs, inputs, trash,
labels);
m2assert_AssertLocation (location);
/* ASM statements without outputs, including simple ones, are treated
as volatile. */
ASM_INPUT_P (args) = isSimple;
ASM_VOLATILE_P (args) = isVolatile;
add_stmt (location, args);
}
/* BuildUnaryForeachWordDo - provides the large set operators. Each
word (or less) of the set can be calculated by unop. This
procedure runs along each word of the large set invoking the unop. */
void
m2statement_BuildUnaryForeachWordDo (location_t location, tree type, tree op1,
tree op2,
tree (*unop) (location_t, tree, int),
int is_op1lvalue, int is_op2lvalue,
int is_op1const, int is_op2const)
{
tree size = m2expr_GetSizeOf (location, type);
m2assert_AssertLocation (location);
ASSERT_BOOL (is_op1lvalue);
ASSERT_BOOL (is_op2lvalue);
ASSERT_BOOL (is_op1const);
ASSERT_BOOL (is_op2const);
if (m2expr_CompareTrees (
size, m2decl_BuildIntegerConstant (SET_WORD_SIZE / BITS_PER_UNIT))
<= 0)
/* Small set size <= TSIZE(WORD). */
m2statement_BuildAssignmentTree (
location, m2treelib_get_rvalue (location, op1, type, is_op1lvalue),
(*unop) (location,
m2treelib_get_rvalue (location, op2, type, is_op2lvalue),
FALSE));
else
{
/* Large set size > TSIZE(WORD). */
unsigned int fieldNo = 0;
tree field1 = m2treelib_get_field_no (type, op1, is_op1const, fieldNo);
tree field2 = m2treelib_get_field_no (type, op2, is_op2const, fieldNo);
if (is_op1const)
error ("internal error: not expecting operand1 to be a constant set");
while (field1 != NULL && field2 != NULL)
{
m2statement_BuildAssignmentTree (
location, m2treelib_get_set_field_des (location, op1, field1),
(*unop) (location,
m2treelib_get_set_field_rhs (location, op2, field2),
FALSE));
fieldNo++;
field1 = m2treelib_get_field_no (type, op1, is_op1const, fieldNo);
field2 = m2treelib_get_field_no (type, op2, is_op2const, fieldNo);
}
}
}
/* BuildExcludeVarConst - builds the EXCL(op1, 1<<op2) operation for
a small sets. Large sets call this routine to exclude the bit in
the particular word. op2 is a constant. */
void
m2statement_BuildExcludeVarConst (location_t location, tree type, tree op1,
tree op2, int is_lvalue, int fieldno)
{
tree size = m2expr_GetSizeOf (location, type);
m2assert_AssertLocation (location);
ASSERT_BOOL (is_lvalue);
if (m2expr_CompareTrees (
size, m2decl_BuildIntegerConstant (SET_WORD_SIZE / BITS_PER_UNIT))
<= 0)
{
/* Small set size <= TSIZE(WORD). */
m2statement_BuildAssignmentTree (
location, m2treelib_get_rvalue (location, op1, type, is_lvalue),
m2expr_BuildLogicalAnd (
location, m2treelib_get_rvalue (location, op1, type, is_lvalue),
m2expr_BuildSetNegate (
location,
m2expr_BuildLSL (location, m2expr_GetWordOne (location), op2,
FALSE),
FALSE),
FALSE));
}
else
{
tree fieldlist = TYPE_FIELDS (type);
tree field;
for (field = fieldlist; (field != NULL) && (fieldno > 0);
field = TREE_CHAIN (field))
fieldno--;
m2statement_BuildAssignmentTree (
location, m2treelib_get_set_field_des (location, op1, field),
m2expr_BuildLogicalAnd (
location, m2treelib_get_set_field_rhs (location, op1, field),
m2expr_BuildSetNegate (
location,
m2expr_BuildLSL (location, m2expr_GetWordOne (location), op2,
FALSE),
FALSE),
FALSE));
}
}
/* BuildExcludeVarVar - builds the EXCL(varset, 1<<varel) operation
for a small and large sets. varel is a variable. */
void
m2statement_BuildExcludeVarVar (location_t location, tree type, tree varset,
tree varel, int is_lvalue, tree low)
{
tree size = m2expr_GetSizeOf (location, type);
m2assert_AssertLocation (location);
ASSERT_BOOL (is_lvalue);
/* Calculate the index from the first bit, ie bit 0 represents low value. */
tree index
= m2expr_BuildSub (location, m2convert_ToInteger (location, varel),
m2convert_ToInteger (location, low), FALSE);
if (m2expr_CompareTrees (
size, m2decl_BuildIntegerConstant (SET_WORD_SIZE / BITS_PER_UNIT))
<= 0)
/* Small set size <= TSIZE(WORD). */
m2statement_BuildAssignmentTree (
location, m2treelib_get_rvalue (location, varset, type, is_lvalue),
m2expr_BuildLogicalAnd (
location, m2treelib_get_rvalue (location, varset, type, is_lvalue),
m2expr_BuildSetNegate (
location,
m2expr_BuildLSL (location, m2expr_GetWordOne (location),
m2convert_ToWord (location, index), FALSE),
FALSE),
FALSE));
else
{
tree p1 = m2treelib_get_set_address (location, varset, is_lvalue);
/* Calculate the index from the first bit. */
/* Which word do we need to fetch? */
tree word_index = m2expr_BuildDivTrunc (
location, index, m2decl_BuildIntegerConstant (SET_WORD_SIZE), FALSE);
/* Calculate the bit in this word. */
tree offset_into_word = m2expr_BuildModTrunc (
location, index, m2decl_BuildIntegerConstant (SET_WORD_SIZE), FALSE);
tree v1;
/* Calculate the address of the word we are interested in. */
p1 = m2expr_BuildAddAddress (
location, m2convert_convertToPtr (location, p1),
m2expr_BuildMult (
location, word_index,
m2decl_BuildIntegerConstant (SET_WORD_SIZE / BITS_PER_UNIT),
FALSE));
v1 = m2expr_BuildLogicalAnd (
location,
m2expr_BuildIndirect (location, p1, m2type_GetBitsetType ()),
m2expr_BuildSetNegate (
location,
m2expr_BuildLSL (location, m2expr_GetWordOne (location),
m2convert_ToWord (location, offset_into_word),
FALSE),
FALSE),
FALSE);
/* Set bit offset_into_word within the word pointer at by p1. */
m2statement_BuildAssignmentTree (
location,
m2expr_BuildIndirect (location, p1, m2type_GetBitsetType ()),
m2convert_ToBitset (location, v1));
}
}
/* BuildIncludeVarConst - builds the INCL(op1, 1<<op2) operation for
a small sets. Large sets call this routine to include the bit in
the particular word. op2 is a constant. */
void
m2statement_BuildIncludeVarConst (location_t location, tree type, tree op1,
tree op2, int is_lvalue, int fieldno)
{
tree size = m2expr_GetSizeOf (location, type);
m2assert_AssertLocation (location);
ASSERT_BOOL (is_lvalue);
if (m2expr_CompareTrees (
size, m2decl_BuildIntegerConstant (SET_WORD_SIZE / BITS_PER_UNIT))
<= 0)
{
/* Small set size <= TSIZE(WORD). */
m2statement_BuildAssignmentTree (
location, m2treelib_get_rvalue (location, op1, type, is_lvalue),
m2expr_BuildLogicalOr (
location, m2treelib_get_rvalue (location, op1, type, is_lvalue),
m2expr_BuildLSL (location, m2expr_GetWordOne (location),
m2convert_ToWord (location, op2), FALSE),
FALSE));
}
else
{
tree fieldlist = TYPE_FIELDS (type);
tree field;
for (field = fieldlist; (field != NULL) && (fieldno > 0);
field = TREE_CHAIN (field))
fieldno--;
m2statement_BuildAssignmentTree (
location,
/* Would like to use: m2expr_BuildComponentRef (location, p, field)
but strangely we have to take the address of the field and
dereference it to satify the gimplifier. See
testsuite/gm2/pim/pass/timeio?.mod for testcases. */
m2treelib_get_set_field_des (location, op1, field),
m2expr_BuildLogicalOr (
location, m2treelib_get_set_field_rhs (location, op1, field),
m2expr_BuildLSL (location, m2expr_GetWordOne (location),
m2convert_ToWord (location, op2), FALSE),
FALSE));
}
}
/* BuildIncludeVarVar - builds the INCL(varset, 1<<varel) operation
for a small and large sets. op2 is a variable. */
void
m2statement_BuildIncludeVarVar (location_t location, tree type, tree varset,
tree varel, int is_lvalue, tree low)
{
tree size = m2expr_GetSizeOf (location, type);
m2assert_AssertLocation (location);
ASSERT_BOOL (is_lvalue);
/* Calculate the index from the first bit, ie bit 0 represents low value. */
tree index
= m2expr_BuildSub (location, m2convert_ToInteger (location, varel),
m2convert_ToInteger (location, low), FALSE);
tree indexw = m2convert_ToWord (location, index);
if (m2expr_CompareTrees (
size, m2decl_BuildIntegerConstant (SET_WORD_SIZE / BITS_PER_UNIT))
<= 0)
/* Small set size <= TSIZE(WORD). */
m2statement_BuildAssignmentTree (
location, m2treelib_get_rvalue (location, varset, type, is_lvalue),
m2convert_ToBitset (
location,
m2expr_BuildLogicalOr (
location,
m2treelib_get_rvalue (location, varset, type, is_lvalue),
m2expr_BuildLSL (location, m2expr_GetWordOne (location),
indexw, FALSE),
FALSE)));
else
{
tree p1 = m2treelib_get_set_address (location, varset, is_lvalue);
/* Which word do we need to fetch? */
tree word_index = m2expr_BuildDivTrunc (
location, index, m2decl_BuildIntegerConstant (SET_WORD_SIZE), FALSE);
/* Calculate the bit in this word. */
tree offset_into_word = m2convert_BuildConvert (
location, m2type_GetWordType (),
m2expr_BuildModTrunc (location, index,
m2decl_BuildIntegerConstant (SET_WORD_SIZE),
FALSE),
FALSE);
tree v1;
/* Calculate the address of the word we are interested in. */
p1 = m2expr_BuildAddAddress (
location, m2convert_convertToPtr (location, p1),
m2expr_BuildMult (
location, word_index,
m2decl_BuildIntegerConstant (SET_WORD_SIZE / BITS_PER_UNIT),
FALSE));
v1 = m2expr_BuildLogicalOr (
location,
m2expr_BuildIndirect (location, p1, m2type_GetBitsetType ()),
m2convert_ToBitset (location,
m2expr_BuildLSL (location,
m2expr_GetWordOne (location),
offset_into_word, FALSE)),
FALSE);
/* Set bit offset_into_word within the word pointer at by p1. */
m2statement_BuildAssignmentTree (
location,
m2expr_BuildIndirect (location, p1, m2type_GetBitsetType ()),
m2convert_ToBitset (location, v1));
}
}
/* BuildStart - creates a module initialization function. We make
this function public if it is not an inner module. The linker
will create a call list for all linked modules which determines
the initialization sequence for all modules. */
tree
m2statement_BuildStart (location_t location, char *name, int inner_module)
{
tree fntype;
tree fndecl;
m2assert_AssertLocation (location);
/* The function type depends on the return type and type of args. */
fntype = build_function_type (integer_type_node, NULL_TREE);
fndecl = build_decl (location, FUNCTION_DECL, get_identifier (name), fntype);
DECL_EXTERNAL (fndecl) = 0;
if (inner_module)
TREE_PUBLIC (fndecl) = 0;
else
TREE_PUBLIC (fndecl) = 1;
TREE_STATIC (fndecl) = 1;
DECL_RESULT (fndecl)
= build_decl (location, RESULT_DECL, NULL_TREE, integer_type_node);
DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;
/* Prevent the optimizer from removing it if it is public. */
if (TREE_PUBLIC (fndecl))
gm2_mark_addressable (fndecl);
m2statement_BuildStartFunctionCode (location, fndecl, !inner_module,
inner_module);
return fndecl;
}
/* BuildEnd - complete the initialisation function for this module. */
void
m2statement_BuildEnd (location_t location, tree fndecl, int nested)
{
m2statement_BuildEndFunctionCode (location, fndecl, nested);
current_function_decl = NULL;
set_cfun (NULL);
}
/* BuildCallInner - call the inner module function. It has no
parameters and no return value. */
void
m2statement_BuildCallInner (location_t location, tree fndecl)
{
m2assert_AssertLocation (location);
param_list = NULL_TREE;
add_stmt (location,
m2statement_BuildProcedureCallTree (location, fndecl, NULL_TREE));
}
/* BuildStartMainModule - expands all the global variables ready for
the main module. */
void
m2statement_BuildStartMainModule (void)
{
/* Nothing to do here. */
}
/* BuildEndMainModule - tidies up the end of the main module. It
moves back to global scope. */
void
m2statement_BuildEndMainModule (void)
{
/* Nothing to do here. */
}
/* BuildIfThenDoEnd - returns a tree which will only execute
statement, s, if, condition, is true. */
tree
m2statement_BuildIfThenDoEnd (tree condition, tree then_block)
{
if (then_block == NULL_TREE)
return NULL_TREE;
else
return fold_build3 (COND_EXPR, void_type_node, condition, then_block,
alloc_stmt_list ());
}
/* BuildIfThenElseEnd - returns a tree which will execute then_block
or else_block depending upon, condition. */
tree
m2statement_BuildIfThenElseEnd (tree condition, tree then_block,
tree else_block)
{
if (then_block == NULL_TREE)
return NULL_TREE;
else
return fold_build3 (COND_EXPR, void_type_node, condition, then_block,
else_block);
}
/* BuildReturnValueCode - generates the code associated with: RETURN(
value ) */
void
m2statement_BuildReturnValueCode (location_t location, tree fndecl, tree value)
{
tree ret_stmt;
tree t;
m2assert_AssertLocation (location);
t = build2 (
MODIFY_EXPR, TREE_TYPE (DECL_RESULT (fndecl)), DECL_RESULT (fndecl),
m2convert_BuildConvert (
location, m2tree_skip_type_decl (TREE_TYPE (DECL_RESULT (fndecl))),
value, FALSE));
ret_stmt = build_stmt (location, RETURN_EXPR, t);
add_stmt (location, ret_stmt);
}
/* DoJump - jump to the appropriate label depending whether result of
the expression is TRUE or FALSE. */
void
m2statement_DoJump (location_t location, tree exp, char *falselabel,
char *truelabel)
{
tree c = NULL_TREE;
m2assert_AssertLocation (location);
if (TREE_CODE (TREE_TYPE (exp)) != BOOLEAN_TYPE)
exp = convert_loc (location, m2type_GetBooleanType (), exp);
if ((falselabel != NULL) && (truelabel == NULL))
{
m2block_push_statement_list (m2block_begin_statement_list ());
m2statement_BuildGoto (location, falselabel);
c = build3 (COND_EXPR, void_type_node, exp,
m2block_end_statement_list (m2block_pop_statement_list ()),
alloc_stmt_list ());
}
else if ((falselabel == NULL) && (truelabel != NULL))
{
m2block_push_statement_list (m2block_begin_statement_list ());
m2statement_BuildGoto (location, truelabel);
c = build3 (COND_EXPR, void_type_node, exp,
m2block_end_statement_list (m2block_pop_statement_list ()),
alloc_stmt_list ());
}
else
error_at (location, "expecting one and only one label to be declared");
if (c != NULL_TREE)
add_stmt (location, c);
}
#include "gt-m2-m2statement.h"
-----------------------------
New file: gcc/m2/gm2-gcc/m2decl.cc
-----------------------------
/* 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"
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. */
/* DeclareKnownVariable - declares a variable in scope, funcscope.
Note that the global variable, current_function_decl, is altered
if isglobal is TRUE. */
tree
m2decl_DeclareKnownVariable (location_t location, 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;
}
/* DetermineSizeOfConstant - given, str, and, base, fill in needsLong
and needsUnsigned appropriately. */
void
m2decl_DetermineSizeOfConstant (const char *str, unsigned int base,
int *needsLong, int *needsUnsigned)
{
int low;
int high;
int overflow;
overflow
= m2expr_interpret_m2_integer (str, base, (unsigned int *)&low, &high);
*needsLong = (high != 0);
if (*needsLong)
*needsUnsigned = (high < 0);
else
*needsUnsigned = (low < 0);
if (overflow)
error ("constant too large");
}
/* 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 (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 (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 ("constant too large");
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 (location_t location, 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"
-----------------------------
New file: gcc/m2/gm2-gcc/m2assert.h
-----------------------------
/* m2assert.h header file for m2assert.cc and assertion macros.
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/>. */
#if !defined(m2assert_h)
#define m2assert_h
#if defined(m2assert_c)
#define EXTERN
#else /* !m2assert_c. */
#define EXTERN extern
#endif /* !m2assert_c. */
#if !defined(ASSERT)
#define ASSERT(X, Y) \
{ \
if (!(X)) \
{ \
debug_tree (Y); \
internal_error ("%s:%d:condition %s failed", __FILE__, __LINE__, \
#X); \
} \
}
#endif
#if !defined(ASSERT_BOOL)
#define ASSERT_BOOL(X) \
{ \
if ((X != 0) && (X != 1)) \
{ \
internal_error ( \
"%s:%d:the value %s is not a BOOLEAN as the value is %d", \
__FILE__, __LINE__, #X, X); \
} \
}
#endif
#if !defined(ASSERT_CONDITION)
#define ASSERT_CONDITION(X) \
{ \
if (!(X)) \
{ \
internal_error ("%s:%d:condition %s failed", __FILE__, __LINE__, \
#X); \
} \
}
#endif
EXTERN void m2assert_AssertLocation (location_t location);
#undef EXTERN
#endif /* m2assert_h. */
-----------------------------
New file: gcc/m2/gm2-gcc/m2search.h
-----------------------------
/* m2search.h header file for m2search.c.
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/>. */
#if !defined(m2search_h)
#define m2search_h
#if defined(m2search_h)
#define EXTERN
#else /* !m2search_h. */
#define EXTERN extern
#endif /* !m2search_h. */
#include "dynamicstrings.h"
EXTERN void M2Search_PrependSearchPath (dynamicstrings_string *s);
#endif /* m2search_c. */
-----------------------------
New file: gcc/m2/gm2-gcc/m2except.h
-----------------------------
/* m2except.h header file for m2except.cc.
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/>. */
#if !defined(m2except_h)
#define m2except_h
#if defined(m2except_c)
#if defined(__GNUG__)
#define EXTERN extern "C"
#else /* !__GNUG__. */
#define EXTERN
#endif /* !__GNUG__. */
#else /* !m2except_c. */
#if defined(__GNUG__)
#define EXTERN extern "C"
#else /* !__GNUG__. */
#define EXTERN extern
#endif /* !__GNUG__. */
#endif /* !m2except_c. */
/* InitExceptions - initialize this module, it declares the external
functions and assigns them to the appropriate global tree
variables. */
EXTERN void m2except_InitExceptions (location_t location);
/* BuildThrow - builds a throw statement and return the tree. */
EXTERN tree m2except_BuildThrow (location_t location, tree exp);
/* BuildTryBegin - returns a tree representing the 'try' block. */
EXTERN tree m2except_BuildTryBegin (location_t location);
/* BuildTryEnd - builds the end of the Try block and prepares for the
catch handlers. */
EXTERN void m2except_BuildTryEnd (tree tryBlock);
/* BuildCatchBegin - creates a handler tree for the C++ statement
'catch (...) {'. It returns the handler tree. */
EXTERN tree m2except_BuildCatchBegin (location_t location);
/* BuildCatchEnd - completes a try catch block. It returns the,
try_block, tree. It creates the C++ statement
'}' which matches the catch above. */
EXTERN tree m2except_BuildCatchEnd (location_t location, tree handler,
tree tryBlock);
#endif /* m2except_h. */
-----------------------------
New file: gcc/m2/gm2-gcc/m2treelib.cc
-----------------------------
/* m2treelib.cc provides call trees, modify_expr and miscelaneous.
Copyright (C) 2012-2022 Free Software Foundation, Inc.
Contributed by Gaius Mulley <gaius@glam.ac.uk>.
This file is part of GNU Modula-2.
GNU Modula-2 is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 3, or (at your option)
any later version.
GNU Modula-2 is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
General Public License for more details.
You should have received a copy of the GNU General Public License
along with GNU Modula-2; see the file COPYING3. If not see
<http://www.gnu.org/licenses/>. */
#include "gcc-consolidation.h"
#include "../gm2-lang.h"
#include "../m2-tree.h"
#define m2treelib_c
#include "m2assert.h"
#include "m2block.h"
#include "m2convert.h"
#include "m2decl.h"
#include "m2expr.h"
#include "m2statement.h"
#include "m2tree.h"
#include "m2treelib.h"
#include "m2treelib.h"
#include "m2type.h"
/* do_jump_if_bit - tests bit in word against integer zero using
operator, code. If the result is true then jump to label. */
void
m2treelib_do_jump_if_bit (location_t location, enum tree_code code, tree word,
tree bit, char *label)
{
word = m2convert_ToWord (location, word);
bit = m2convert_ToWord (location, bit);
m2statement_DoJump (
location,
m2expr_build_binary_op (
location, code,
m2expr_build_binary_op (
location, BIT_AND_EXPR, word,
m2expr_BuildLSL (location, m2expr_GetWordOne (location), bit,
FALSE),
FALSE),
m2expr_GetWordZero (location), FALSE),
NULL, label);
}
/* build_modify_expr - taken from c-typeck.cc and heavily pruned.
Build an assignment expression of lvalue LHS from value RHS. If
LHS_ORIGTYPE is not NULL, it is the original type of LHS, which
may differ from TREE_TYPE (LHS) for an enum bitfield. MODIFYCODE
is the code for a binary operator that we use to combine the old
value of LHS with RHS to get the new value. Or else MODIFYCODE is
NOP_EXPR meaning do a simple assignment. If RHS_ORIGTYPE is not
NULL_TREE, it is the original type of RHS, which may differ from
TREE_TYPE (RHS) for an enum value.
LOCATION is the location of the MODIFYCODE operator. RHS_LOC is the
location of the RHS. */
static tree
build_modify_expr (location_t location, tree lhs, enum tree_code modifycode,
tree rhs)
{
tree result;
tree newrhs;
tree rhs_semantic_type = NULL_TREE;
tree lhstype = TREE_TYPE (lhs);
tree olhstype = lhstype;
ASSERT_CONDITION (modifycode == NOP_EXPR);
if (TREE_CODE (rhs) == EXCESS_PRECISION_EXPR)
{
rhs_semantic_type = TREE_TYPE (rhs);
rhs = TREE_OPERAND (rhs, 0);
}
newrhs = rhs;
/* If storing into a structure or union member, it has probably been
given type `int'. Compute the type that would go with the actual
amount of storage the member occupies. */
if (TREE_CODE (lhs) == COMPONENT_REF
&& (TREE_CODE (lhstype) == INTEGER_TYPE
|| TREE_CODE (lhstype) == BOOLEAN_TYPE
|| TREE_CODE (lhstype) == REAL_TYPE
|| TREE_CODE (lhstype) == ENUMERAL_TYPE))
lhstype = TREE_TYPE (get_unwidened (lhs, 0));
/* If storing in a field that is in actuality a short or narrower
than one, we must store in the field in its actual type. */
if (lhstype != TREE_TYPE (lhs))
{
lhs = copy_node (lhs);
TREE_TYPE (lhs) = lhstype;
}
newrhs = fold (newrhs);
if (rhs_semantic_type)
newrhs = build1 (EXCESS_PRECISION_EXPR, rhs_semantic_type, newrhs);
/* Scan operands. */
result = build2 (MODIFY_EXPR, lhstype, lhs, newrhs);
TREE_SIDE_EFFECTS (result) = 1;
protected_set_expr_location (result, location);
/* If we got the LHS in a different type for storing in, convert the
result back to the nominal type of LHS so that the value we return
always has the same type as the LHS argument. */
ASSERT_CONDITION (olhstype == TREE_TYPE (result));
/* In Modula-2 I'm assuming this will be true this maybe wrong, but
at least I'll know about it soon. If true then we do not need to
implement convert_for_assignment - which is a huge win. */
return result;
}
/* m2treelib_build_modify_expr - wrapper function for
build_modify_expr. */
tree
m2treelib_build_modify_expr (location_t location, tree des,
enum tree_code modifycode, tree copy)
{
return build_modify_expr (location, des, modifycode, copy);
}
/* nCount - return the number of trees chained on, t. */
static int
nCount (tree t)
{
int i = 0;
while (t != NULL)
{
i++;
t = TREE_CHAIN (t);
}
return i;
}
/* DoCall - build a call tree arranging the parameter list as a
vector. */
tree
m2treelib_DoCall (location_t location, tree rettype, tree funcptr,
tree param_list)
{
int n = nCount (param_list);
tree *argarray = XALLOCAVEC (tree, n);
tree l = param_list;
int i;
for (i = 0; i < n; i++)
{
argarray[i] = TREE_VALUE (l);
l = TREE_CHAIN (l);
}
return build_call_array_loc (location, rettype, funcptr, n, argarray);
}
/* DoCall0 - build a call tree with no parameters. */
tree
m2treelib_DoCall0 (location_t location, tree rettype, tree funcptr)
{
tree *argarray = XALLOCAVEC (tree, 1);
argarray[0] = NULL_TREE;
return build_call_array_loc (location, rettype, funcptr, 0, argarray);
}
/* DoCall1 - build a call tree with 1 parameter. */
tree
m2treelib_DoCall1 (location_t location, tree rettype, tree funcptr, tree arg0)
{
tree *argarray = XALLOCAVEC (tree, 1);
argarray[0] = arg0;
return build_call_array_loc (location, rettype, funcptr, 1, argarray);
}
/* DoCall2 - build a call tree with 2 parameters. */
tree
m2treelib_DoCall2 (location_t location, tree rettype, tree funcptr, tree arg0,
tree arg1)
{
tree *argarray = XALLOCAVEC (tree, 2);
argarray[0] = arg0;
argarray[1] = arg1;
return build_call_array_loc (location, rettype, funcptr, 2, argarray);
}
/* DoCall3 - build a call tree with 3 parameters. */
tree
m2treelib_DoCall3 (location_t location, tree rettype, tree funcptr, tree arg0,
tree arg1, tree arg2)
{
tree *argarray = XALLOCAVEC (tree, 3);
argarray[0] = arg0;
argarray[1] = arg1;
argarray[2] = arg2;
return build_call_array_loc (location, rettype, funcptr, 3, argarray);
}
/* get_rvalue - returns the rvalue of t. The, type, is the object
type to be copied upon indirection. */
tree
m2treelib_get_rvalue (location_t location, tree t, tree type, int is_lvalue)
{
if (is_lvalue)
return m2expr_BuildIndirect (location, t, type);
else
return t;
}
/* get_field_no - returns the field no for, op. The, op, is either a
constructor or a variable of type record. If, op, is a
constructor (a set constant in GNU Modula-2) then this function is
essentially a no-op and it returns op. Else we iterate over the
field list and return the appropriate field number. */
tree
m2treelib_get_field_no (tree type, tree op, int is_const, unsigned int fieldNo)
{
ASSERT_BOOL (is_const);
if (is_const)
return op;
else
{
tree list = TYPE_FIELDS (type);
while (fieldNo > 0 && list != NULL_TREE)
{
list = TREE_CHAIN (list);
fieldNo--;
}
return list;
}
}
/* get_set_value - returns the value indicated by, field, in the set.
Either p->field or the constant(op.fieldNo) is returned. */
tree
m2treelib_get_set_value (location_t location, tree p, tree field, int is_const,
int is_lvalue, tree op, unsigned int fieldNo)
{
tree value;
constructor_elt *ce;
ASSERT_BOOL (is_const);
ASSERT_BOOL (is_lvalue);
if (is_const)
{
ASSERT_CONDITION (is_lvalue == FALSE);
gcc_assert (!vec_safe_is_empty (CONSTRUCTOR_ELTS (op)));
unsigned int size = vec_safe_length (CONSTRUCTOR_ELTS (op));
if (size < fieldNo)
internal_error ("field number exceeds definition of set");
if (vec_safe_iterate (CONSTRUCTOR_ELTS (op), fieldNo, &ce))
value = ce->value;
else
internal_error (
"field number out of range trying to access set element");
}
else if (is_lvalue)
{
if (TREE_CODE (TREE_TYPE (p)) == POINTER_TYPE)
value = m2expr_BuildComponentRef (
location, m2expr_BuildIndirect (location, p, TREE_TYPE (p)),
field);
else
{
ASSERT_CONDITION (TREE_CODE (TREE_TYPE (p)) == REFERENCE_TYPE);
value = m2expr_BuildComponentRef (location, p, field);
}
}
else
{
tree type = TREE_TYPE (op);
enum tree_code code = TREE_CODE (type);
ASSERT_CONDITION (code == RECORD_TYPE
|| (code == POINTER_TYPE
&& (TREE_CODE (TREE_TYPE (type)) == RECORD_TYPE)));
value = m2expr_BuildComponentRef (location, op, field);
}
value = m2convert_ToBitset (location, value);
return value;
}
/* get_set_address - returns the address of op1. */
tree
m2treelib_get_set_address (location_t location, tree op1, int is_lvalue)
{
if (is_lvalue)
return op1;
else
return m2expr_BuildAddr (location, op1, FALSE);
}
/* get_set_field_lhs - returns the address of p->field. */
tree
m2treelib_get_set_field_lhs (location_t location, tree p, tree field)
{
return m2expr_BuildAddr (
location, m2convert_ToBitset (
location, m2expr_BuildComponentRef (location, p, field)),
FALSE);
}
/* get_set_field_rhs - returns the value of p->field. */
tree
m2treelib_get_set_field_rhs (location_t location, tree p, tree field)
{
return m2convert_ToBitset (location,
m2expr_BuildComponentRef (location, p, field));
}
/* get_set_field_des - returns the p->field ready to be a (rhs)
designator. */
tree
m2treelib_get_set_field_des (location_t location, tree p, tree field)
{
return m2expr_BuildIndirect (
location,
m2expr_BuildAddr (location,
m2expr_BuildComponentRef (location, p, field), FALSE),
m2type_GetBitsetType ());
}
/* get_set_address_if_var - returns the address of, op, providing it
is not a constant. NULL is returned if, op, is a constant. */
tree
m2treelib_get_set_address_if_var (location_t location, tree op, int is_lvalue,
int is_const)
{
if (is_const)
return NULL;
else
return m2treelib_get_set_address (location, op, is_lvalue);
}
/* add_stmt - t is a statement. Add it to the statement-tree. */
tree
add_stmt (location_t location, tree t)
{
return m2block_add_stmt (location, t);
}
/* taken from gcc/c-semantics.cc. */
/* Build a generic statement based on the given type of node and
arguments. Similar to `build_nt', except that we set EXPR_LOCATION
to LOC. */
tree
build_stmt (location_t loc, enum tree_code code, ...)
{
tree ret;
int length, i;
va_list p;
bool side_effects;
m2assert_AssertLocation (loc);
/* This function cannot be used to construct variably-sized nodes. */
gcc_assert (TREE_CODE_CLASS (code) != tcc_vl_exp);
va_start (p, code);
ret = make_node (code);
TREE_TYPE (ret) = void_type_node;
length = TREE_CODE_LENGTH (code);
SET_EXPR_LOCATION (ret, loc);
/* TREE_SIDE_EFFECTS will already be set for statements with implicit
side effects. Here we make sure it is set for other expressions by
checking whether the parameters have side effects. */
side_effects = false;
for (i = 0; i < length; i++)
{
tree t = va_arg (p, tree);
if (t && !TYPE_P (t))
side_effects |= TREE_SIDE_EFFECTS (t);
TREE_OPERAND (ret, i) = t;
}
TREE_SIDE_EFFECTS (ret) |= side_effects;
va_end (p);
return ret;
}
-----------------------------
New file: gcc/m2/gm2-gcc/m2color.cc
-----------------------------
/* 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"
const char *m2color_colorize_start (bool show_color, char *name, unsigned int name_len)
{
return colorize_start (show_color, name, name_len);
}
const char *m2color_colorize_stop (bool show_color)
{
return colorize_stop (show_color);
}
const char *m2color_open_quote (void)
{
return open_quote;
}
const char *m2color_close_quote (void)
{
return close_quote;
}
void _M2_m2color_init ()
{
}
void _M2_m2color_finish ()
{
}
-----------------------------
New file: gcc/m2/gm2-gcc/m2options.h
-----------------------------
/* m2options.h header file for M2Options.mod.
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/>. */
#if !defined(m2options_h)
#define m2options_h
#if defined(m2options_c)
#if defined(__GNUG__)
#define EXTERN extern "C"
#else /* !__GNUG__. */
#define EXTERN
#endif /* !__GNUG__. */
#else /* !m2options_c. */
#if defined(__GNUG__)
#define EXTERN extern "C"
#else /* !__GNUG__. */
#define EXTERN extern
#endif /* !__GNUG__. */
#endif /* !m2options_c. */
#include "input.h"
EXTERN void M2Options_SetMakeIncludePath (const char *arg);
EXTERN void M2Options_SetSearchPath (const char *arg);
EXTERN void M2Options_setdefextension (const char *arg);
EXTERN void M2Options_setmodextension (const char *arg);
EXTERN void M2Options_SetISO (int value);
EXTERN void M2Options_SetPIM (int value);
EXTERN void M2Options_SetPIM2 (int value);
EXTERN void M2Options_SetPIM3 (int value);
EXTERN void M2Options_SetPIM4 (int value);
EXTERN void M2Options_SetFloatValueCheck (int value);
EXTERN void M2Options_SetWholeValueCheck (int value);
EXTERN int M2Options_GetISO (void);
EXTERN int M2Options_GetPIM (void);
EXTERN int M2Options_GetPIM2 (void);
EXTERN int M2Options_GetPIM3 (void);
EXTERN int M2Options_GetPIM4 (void);
EXTERN int M2Options_GetPositiveModFloor (void);
EXTERN int M2Options_GetFloatValueCheck (void);
EXTERN int M2Options_GetWholeValueCheck (void);
EXTERN void M2Options_SetAutoInit (int value);
EXTERN void M2Options_SetPositiveModFloor (int value);
EXTERN void M2Options_SetNilCheck (int value);
EXTERN void M2Options_SetWholeDiv (int value);
EXTERN void M2Options_SetIndex (int value);
EXTERN void M2Options_SetRange (int value);
EXTERN void M2Options_SetReturnCheck (int value);
EXTERN void M2Options_SetCaseCheck (int value);
EXTERN void M2Options_SetCheckAll (int value);
EXTERN void M2Options_SetExceptions (int value);
EXTERN void M2Options_SetStudents (int value);
EXTERN void M2Options_SetPedantic (int value);
EXTERN void M2Options_SetPedanticParamNames (int value);
EXTERN void M2Options_SetPedanticCast (int value);
EXTERN void M2Options_SetExtendedOpaque (int value);
EXTERN void M2Options_SetVerboseUnbounded (int value);
EXTERN void M2Options_SetXCode (int value);
EXTERN void M2Options_SetCompilerDebugging (int value);
EXTERN void M2Options_SetQuadDebugging (int value);
EXTERN void M2Options_SetDebugTraceQuad (int value);
EXTERN void M2Options_SetDebugTraceAPI (int value);
EXTERN void M2Options_SetSources (int value);
EXTERN void M2Options_SetUnboundedByReference (int value);
EXTERN void M2Options_SetDumpSystemExports (int value);
EXTERN void M2Options_SetOptimizing (int value);
EXTERN void M2Options_SetQuiet (int value);
EXTERN void M2Options_SetCC1Quiet (int value);
EXTERN void M2Options_SetCpp (int value);
EXTERN void M2Options_SetSwig (int value);
EXTERN void M2Options_SetForcedLocation (location_t location);
EXTERN location_t M2Options_OverrideLocation (location_t location);
EXTERN void M2Options_SetStatistics (int on);
EXTERN void M2Options_CppProg (const char *program);
EXTERN void M2Options_CppArg (const char *opt, const char *arg, int joined);
EXTERN void M2Options_SetWholeProgram (int value);
EXTERN void M2Options_FinaliseOptions (void);
EXTERN void M2Options_SetDebugFunctionLineNumbers (int value);
EXTERN void M2Options_SetGenerateStatementNote (int value);
EXTERN int M2Options_GetCpp (void);
EXTERN int M2Options_GetM2g (void);
EXTERN void M2Options_SetM2g (int value);
EXTERN void M2Options_SetLowerCaseKeywords (int value);
EXTERN void M2Options_SetUnusedVariableChecking (int value);
EXTERN void M2Options_SetUnusedParameterChecking (int value);
EXTERN void M2Options_SetStrictTypeChecking (int value);
EXTERN void M2Options_SetWall (int value);
EXTERN void M2Options_SetSaveTemps (int value);
EXTERN void M2Options_SetSaveTempsDir (const char *arg);
EXTERN int M2Options_GetSaveTemps (void);
EXTERN void M2Options_DisplayVersion (int mustExit);
#undef EXTERN
#endif /* m2options_h. */
-----------------------------
New file: gcc/m2/gm2-gcc/m2block.h
-----------------------------
/* m2block.h header file for m2block.cc.
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/>. */
#if !defined(m2block_h)
#define m2block_h
#if defined(m2block_c)
#if defined(__GNUG__)
#define EXTERN extern "C"
#else /* !__GNUG__. */
#define EXTERN
#endif /* !__GNUG__. */
#else /* !m2block_c. */
#if defined(__GNUG__)
#define EXTERN extern "C"
#else /* !m2block_h. */
#define EXTERN extern
#endif /* !m2block_c. */
#endif /* !m2block_h. */
EXTERN tree m2block_getLabel (location_t location, char *name);
EXTERN void m2block_pushFunctionScope (tree fndecl);
EXTERN tree m2block_popFunctionScope (void);
EXTERN void m2block_pushGlobalScope (void);
EXTERN void m2block_popGlobalScope (void);
EXTERN tree m2block_pushDecl (tree decl);
EXTERN void m2block_addDeclExpr (tree t);
EXTERN tree m2block_end_statement_list (tree t);
EXTERN tree m2block_begin_statement_list (void);
EXTERN tree m2block_push_statement_list (tree t);
EXTERN tree m2block_pop_statement_list (void);
EXTERN void m2block_finishFunctionDecl (location_t location, tree fndecl);
EXTERN void m2block_finishFunctionCode (tree fndecl);
EXTERN tree m2block_RememberType (tree t);
EXTERN tree m2block_RememberConstant (tree t);
EXTERN tree m2block_DumpGlobalConstants (void);
EXTERN tree m2block_RememberInitModuleFunction (tree t);
EXTERN tree m2block_global_constant (tree t);
EXTERN int m2block_toplevel (void);
EXTERN tree m2block_GetErrorNode (void);
EXTERN void m2block_addStmtNote (location_t location);
EXTERN tree m2block_cur_stmt_list (void);
EXTERN tree *m2block_cur_stmt_list_addr (void);
EXTERN int m2block_is_building_stmt_list (void);
EXTERN tree m2block_GetGlobals (void);
EXTERN tree m2block_GetGlobalContext (void);
EXTERN void m2block_finishGlobals (void);
EXTERN void m2block_includeDecl (tree);
EXTERN tree m2block_add_stmt (location_t location, tree t);
EXTERN void m2block_addStmtNote (location_t location);
EXTERN void m2block_removeStmtNote (void);
EXTERN void m2block_init (void);
#undef EXTERN
#endif /* m2block_h. */
-----------------------------
New file: gcc/m2/gm2-gcc/gcc-consolidation.h
-----------------------------
/* gcc-consolidation.h provides a single header for required gcc headers.
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 "config.h"
#include "system.h"
#include "coretypes.h"
#include "realmpfr.h"
#include "backend.h"
#include "stringpool.h"
#include "rtl.h"
#include "tree.h"
#include "predict.h"
#include "df.h"
#include "tm.h"
#include "hash-set.h"
#include "machmode.h"
#include "vec.h"
#include "double-int.h"
#include "input.h"
#include "alias.h"
#include "symtab.h"
#include "options.h"
#include "wide-int.h"
#include "inchash.h"
#include "stor-layout.h"
#include "attribs.h"
#include "intl.h"
#include "tree-iterator.h"
#include "diagnostic.h"
#include "wide-int-print.h"
#include "real.h"
#include "float.h"
#include "spellcheck.h"
#include "opt-suggestions.h"
#if !defined(GM2TOOLS)
/* Utilize some of the C build routines. */
#include "fold-const.h"
#include "varasm.h"
#include "hashtab.h"
#include "hard-reg-set.h"
#include "function.h"
#include "hash-map.h"
#include "langhooks.h"
#include "timevar.h"
#include "dumpfile.h"
#include "target.h"
#include "dominance.h"
#include "cfg.h"
#include "cfganal.h"
#include "predict.h"
#include "basic-block.h"
#include "df.h"
#include "tree-ssa-alias.h"
#include "internal-fn.h"
#include "gimple-expr.h"
#include "is-a.h"
#include "gimple.h"
#include "gimple-ssa.h"
#include "gimplify.h"
#include "stringpool.h"
#include "tree-nested.h"
#include "print-tree.h"
#include "except.h"
#include "toplev.h"
#include "convert.h"
#include "tree-dump.h"
#include "plugin-api.h"
#include "hard-reg-set.h"
#include "function.h"
#include "ipa-ref.h"
#include "cgraph.h"
#include "stmt.h"
#endif /* GM2TOOLS. */
-----------------------------
New file: gcc/m2/gm2-gcc/m2expr.h
-----------------------------
/* m2expr.h header file for m2expr.cc.
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/>. */
#if !defined(m2expr_h)
#define m2expr_h
#if defined(m2expr_c)
#if defined(__GNUG__)
#define EXTERN extern "C"
#else /* !__GNUG__. */
#define EXTERN
#endif /* !__GNUG__. */
#else /* !m2expr_c. */
#if defined(__GNUG__)
#define EXTERN extern "C"
#else /* !__GNUG__. */
#define EXTERN extern
#endif /* !__GNUG__. */
#endif /* !m2expr_c. */
EXTERN void m2expr_BuildBinaryForeachWordDo (
location_t location, tree type, tree op1, tree op2, tree op3,
tree (*binop) (location_t, tree, tree, int), int is_op1lvalue,
int is_op2lvalue, int is_op3lvalue, int is_op1const, int is_op2const,
int is_op3const);
EXTERN tree m2expr_BuildCmplx (location_t location, tree type, tree real,
tree imag);
EXTERN tree m2expr_BuildIm (tree op1);
EXTERN tree m2expr_BuildRe (tree op1);
EXTERN tree m2expr_BuildAbs (location_t location, tree t);
EXTERN tree m2expr_BuildCap (location_t location, tree t);
EXTERN int m2expr_DetermineSign (tree e);
EXTERN int m2expr_AreRealOrComplexConstantsEqual (tree e1, tree e2);
EXTERN int m2expr_AreConstantsEqual (tree e1, tree e2);
EXTERN int m2expr_IsFalse (tree t);
EXTERN int m2expr_IsTrue (tree t);
EXTERN tree m2expr_BuildIndirect (location_t location, tree target, tree type);
EXTERN tree m2expr_BuildComponentRef (location_t location, tree record,
tree field);
EXTERN tree m2expr_BuildArray (location_t location, tree type, tree array,
tree index, tree lowIndice);
EXTERN void m2expr_BuildIfNotInRangeGoto (location_t location, tree var,
tree low, tree high, char *label);
EXTERN void m2expr_BuildIfInRangeGoto (location_t location, tree var, tree low,
tree high, char *label);
EXTERN void m2expr_BuildForeachWordInSetDoIfExpr (
location_t location, tree type, tree op1, tree op2, int is_op1lvalue,
int is_op2lvalue, int is_op1const, int is_op2const,
tree (*expr) (location_t, tree, tree), char *label);
EXTERN void m2expr_BuildIfNotVarInVar (location_t location, tree type,
tree varset, tree varel, int is_lvalue,
tree low, tree high ATTRIBUTE_UNUSED,
char *label);
EXTERN void m2expr_BuildIfVarInVar (location_t location, tree type,
tree varset, tree varel, int is_lvalue,
tree low, tree high ATTRIBUTE_UNUSED,
char *label);
EXTERN void m2expr_BuildIfNotConstInVar (location_t location, tree type,
tree varset, tree constel,
int is_lvalue, int fieldno,
char *label);
EXTERN void m2expr_BuildIfConstInVar (location_t location, tree type,
tree varset, tree constel, int is_lvalue,
int fieldno, char *label);
EXTERN tree m2expr_BuildIsNotSubset (location_t location, tree op1, tree op2);
EXTERN tree m2expr_BuildIsSubset (location_t location, tree op1, tree op2);
EXTERN tree m2expr_BuildIsNotSuperset (location_t location, tree op1,
tree op2);
EXTERN tree m2expr_BuildIsSuperset (location_t location, tree op1, tree op2);
EXTERN tree m2expr_BuildNotEqualTo (location_t location, tree op1, tree op2);
EXTERN tree m2expr_BuildEqualTo (location_t location, tree op1, tree op2);
EXTERN tree m2expr_BuildGreaterThanOrEqual (location_t location, tree op1,
tree op2);
EXTERN tree m2expr_BuildLessThanOrEqual (location_t location, tree op1,
tree op2);
EXTERN tree m2expr_BuildGreaterThan (location_t location, tree op1, tree op2);
EXTERN tree m2expr_BuildLessThan (location_t location, tree op1, tree op2);
EXTERN tree m2expr_BuildLogicalDifference (location_t location, tree op1,
tree op2, int needconvert);
EXTERN tree m2expr_BuildSymmetricDifference (location_t location, tree op1,
tree op2, int needconvert);
EXTERN tree m2expr_BuildLogicalAnd (location_t location, tree op1, tree op2,
int needconvert);
EXTERN tree m2expr_BuildLogicalOr (location_t location, tree op1, tree op2,
int needconvert);
EXTERN tree m2expr_BuildLogicalOrAddress (location_t location, tree op1,
tree op2, int needconvert);
EXTERN tree m2expr_BuildOffset (location_t location, tree record, tree field,
int needconvert ATTRIBUTE_UNUSED);
EXTERN tree m2expr_BuildOffset1 (location_t location, tree field,
int needconvert ATTRIBUTE_UNUSED);
EXTERN tree m2expr_BuildAddr (location_t location, tree op1, int needconvert);
EXTERN tree m2expr_BuildSize (location_t location, tree op1,
int needconvert ATTRIBUTE_UNUSED);
EXTERN tree m2expr_BuildTBitSize (location_t location, tree type);
EXTERN tree m2expr_BuildSetNegate (location_t location, tree op1,
int needconvert);
EXTERN tree m2expr_BuildNegate (location_t location, tree op1,
int needconvert);
EXTERN tree m2expr_BuildNegateCheck (location_t location, tree arg,
tree lowest, tree min, tree max);
EXTERN tree m2expr_BuildTrunc (tree op1);
EXTERN tree m2expr_BuildCoerce (location_t location, tree des, tree type,
tree expr);
EXTERN tree m2expr_RemoveOverflow (tree t);
EXTERN int m2expr_TreeOverflow (tree t);
EXTERN unsigned int m2expr_StringLength (tree string);
EXTERN tree m2expr_FoldAndStrip (tree t);
EXTERN int m2expr_interpret_integer (const char *str, unsigned int base,
unsigned HOST_WIDE_INT *low,
HOST_WIDE_INT *high);
EXTERN int m2expr_interpret_m2_integer (const char *str, unsigned int base,
unsigned int *low, int *high);
EXTERN tree m2expr_BuildAddCheck (location_t location, tree op1, tree op2,
tree lowest, tree min, tree max);
EXTERN tree m2expr_BuildSubCheck (location_t location, tree op1, tree op2,
tree lowest, tree min, tree max);
EXTERN tree m2expr_BuildMultCheck (location_t location, tree op1, tree op2,
tree lowest, tree min, tree max);
EXTERN tree m2expr_BuildAdd (location_t location, tree op1, tree op2,
int needconvert);
EXTERN tree m2expr_BuildSub (location_t location, tree op1, tree op2,
int needconvert);
EXTERN tree m2expr_BuildDivTrunc (location_t location, tree op1, tree op2,
int needconvert);
EXTERN tree m2expr_BuildDivTruncCheck (location_t location, tree op1, tree op2,
tree lowest, tree min, tree max);
EXTERN tree m2expr_BuildModTrunc (location_t location, tree op1, tree op2,
int needconvert);
EXTERN tree m2expr_BuildDivCeil (location_t location, tree op1, tree op2,
int needconvert);
EXTERN tree m2expr_BuildModCeil (location_t location, tree op1, tree op2,
int needconvert);
EXTERN tree m2expr_BuildDivFloor (location_t location, tree op1, tree op2,
int needconvert);
EXTERN tree m2expr_BuildModFloor (location_t location, tree op1, tree op2,
int needconvert);
EXTERN tree m2expr_BuildDivM2 (location_t location, tree op1, tree op2,
unsigned int needsconvert);
EXTERN tree m2expr_BuildModM2 (location_t location, tree op1, tree op2,
unsigned int needsconvert);
EXTERN tree m2expr_BuildDivM2Check (location_t location, tree op1, tree op2,
tree lowest, tree min, tree max);
EXTERN tree m2expr_BuildModM2Check (location_t location, tree op1, tree op2,
tree lowest, tree min, tree max);
EXTERN tree m2expr_BuildLSL (location_t location, tree op1, tree op2,
int needconvert);
EXTERN tree m2expr_BuildLSR (location_t location, tree op1, tree op2,
int needconvert);
EXTERN void m2expr_BuildLogicalShift (location_t location, tree op1, tree op2,
tree op3, tree nBits ATTRIBUTE_UNUSED,
int needconvert);
EXTERN tree m2expr_BuildLRL (location_t location, tree op1, tree op2,
int needconvert);
EXTERN tree m2expr_BuildLRR (location_t location, tree op1, tree op2,
int needconvert);
EXTERN tree m2expr_BuildMult (location_t location, tree op1, tree op2,
int needconvert);
EXTERN tree m2expr_BuildRRotate (location_t location, tree op1, tree nBits,
int needconvert);
EXTERN tree m2expr_BuildLRotate (location_t location, tree op1, tree nBits,
int needconvert);
EXTERN tree m2expr_BuildMask (location_t location, tree nBits,
int needconvert);
EXTERN tree m2expr_BuildLRLn (location_t location, tree op1, tree op2,
tree nBits, int needconvert);
EXTERN tree m2expr_BuildLRRn (location_t location, tree op1, tree op2,
tree nBits, int needconvert);
EXTERN void m2expr_BuildLogicalRotate (location_t location, tree op1, tree op2,
tree op3, tree nBits, int needconvert);
EXTERN void m2expr_BuildBinarySetDo (
location_t location, tree settype, tree op1, tree op2, tree op3,
void (*binop) (location_t, tree, tree, tree, tree, int), int is_op1lvalue,
int is_op2lvalue, int is_op3lvalue, tree nBits, tree unbounded,
tree varproc, tree leftproc, tree rightproc);
EXTERN tree m2expr_GetSizeOf (location_t location, tree type);
EXTERN tree m2expr_GetSizeOfInBits (tree type);
EXTERN tree m2expr_GetCardinalZero (location_t location);
EXTERN tree m2expr_GetCardinalOne (location_t location);
EXTERN tree m2expr_GetIntegerZero (location_t location);
EXTERN tree m2expr_GetIntegerOne (location_t location);
EXTERN tree m2expr_GetWordZero (location_t location);
EXTERN tree m2expr_GetWordOne (location_t location);
EXTERN tree m2expr_GetPointerZero (location_t location);
EXTERN tree m2expr_GetPointerOne (location_t location);
#if 0
EXTERN tree m2expr_GetBooleanTrue (void);
EXTERN tree m2expr_GetBooleanFalse (void);
#endif
EXTERN int m2expr_CompareTrees (tree e1, tree e2);
EXTERN tree m2expr_build_unary_op (location_t location ATTRIBUTE_UNUSED,
enum tree_code code, tree arg,
int flag ATTRIBUTE_UNUSED);
EXTERN tree m2expr_build_binary_op (location_t location, enum tree_code code,
tree op1, tree op2, int convert);
EXTERN tree m2expr_build_binary_op_check (location_t location,
enum tree_code code, tree op1,
tree op2, int needconvert,
tree lowest, tree min, tree max);
EXTERN void m2expr_ConstantExpressionWarning (tree value);
EXTERN tree m2expr_BuildAddAddress (location_t location, tree op1, tree op2);
EXTERN tree m2expr_BuildRDiv (location_t location, tree op1, tree op2,
int needconvert);
EXTERN void m2expr_init (location_t location);
#undef EXTERN
#endif /* m2expr_h. */
-----------------------------
New file: gcc/m2/gm2-gcc/m2convert.cc
-----------------------------
/* 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;
}
-----------------------------
New file: gcc/m2/gm2-gcc/m2top.cc
-----------------------------
/* m2top.cc provides top level scoping functions.
Copyright (C) 2012-2022 Free Software Foundation, Inc.
Contributed by Gaius Mulley <gaius@glam.ac.uk>.
This file is part of GNU Modula-2.
GNU Modula-2 is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 3, or (at your option)
any later version.
GNU Modula-2 is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
General Public License for more details.
You should have received a copy of the GNU General Public License
along with GNU Modula-2; see the file COPYING3. If not see
<http://www.gnu.org/licenses/>. */
#include "gcc-consolidation.h"
#include "../gm2-lang.h"
#include "../m2-tree.h"
#include "m2assert.h"
#include "m2block.h"
#include "m2decl.h"
#include "m2expr.h"
#include "m2tree.h"
#include "m2type.h"
#define m2top_c
#include "m2top.h"
/* StartGlobalContext - initializes a dummy function for the global
scope. */
void
m2top_StartGlobalContext (void)
{
}
/* EndGlobalContext - ends the dummy function for the global scope. */
void
m2top_EndGlobalContext (void)
{
}
/* FinishBackend - flushes all outstanding functions held in the GCC
backend out to the assembly file. */
void
m2top_FinishBackend (void)
{
}
/* SetFlagUnitAtATime - sets GCC flag_unit_at_a_time to b. */
void
m2top_SetFlagUnitAtATime (int b)
{
flag_unit_at_a_time = b;
}
-----------------------------
New file: gcc/m2/gm2-gcc/m2misc.h
-----------------------------
/* m2misc.h header file for m2misc.cc.
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/>. */
#if !defined(m2misc_h)
#define m2misc_h
#if defined(m2misc_c)
#if defined(__GNUG__)
#define EXTERN extern "C"
#else /* !__GNUG__. */
#define EXTERN
#endif /* !__GNUG__. */
#else /* !m2misc_c. */
#if defined(__GNUG__)
#define EXTERN extern "C"
#else /* !__GNUG__. */
#define EXTERN extern
#endif /* !__GNUG__. */
#endif /* !m2misc_c. */
EXTERN void m2misc_DebugTree (tree t);
EXTERN void m2misc_printStmt (void);
EXTERN void m2misc_DebugTreeChain (tree t);
#undef EXTERN
#endif /* m2misc_h. */
-----------------------------
New file: gcc/m2/gm2-gcc/m2except.cc
-----------------------------
/* m2except.cc implements the construction of exception 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 "../m2-tree.h"
#define GM2
#define GM2_BUG_REPORT \
"Please report this crash to the GNU Modula-2 mailing list " \
"<gm2@nongnu.org>\n"
/* External functions. */
#define m2except_c
#include "m2assert.h"
#include "m2block.h"
#include "m2decl.h"
#include "m2expr.h"
#include "m2statement.h"
#include "m2tree.h"
#include "m2treelib.h"
#include "m2type.h"
/* Local prototypes. */
#include "m2except.h"
static tree build_exc_ptr (location_t location);
static tree do_begin_catch (location_t location);
static tree do_end_catch (location_t location);
static tree begin_handler (location_t location);
static void finish_handler (location_t location, tree handler);
static tree finish_handler_parms (location_t location, tree handler);
static void finish_handler_sequence (tree try_block);
static tree begin_try_block (location_t location);
static tree finish_expr_stmt (location_t location, tree expr);
static tree maybe_cleanup_point_expr_void (tree expr);
static tree build_target_expr_with_type (location_t location, tree init,
tree type);
static tree get_target_expr (location_t location, tree init);
static tree build_eh_type_type (location_t location, tree type);
static tree get_tinfo_decl_m2 (location_t location);
static tree eh_type_info (location_t location, tree type);
static tree build_address (tree t);
void _M2_gm2except_init (void);
void _M2_gm2except_finally (void);
/* Exception handling library functions. */
static GTY (()) tree fn_begin_catch_tree = NULL_TREE;
static GTY (()) tree fn_end_catch_tree = NULL_TREE;
static GTY (()) tree fn_throw_tree = NULL_TREE;
static GTY (()) tree fn_rethrow_tree = NULL_TREE;
static GTY (()) tree cleanup_type = NULL_TREE;
static GTY (()) tree fn_allocate_exception_tree = NULL_TREE;
static GTY (()) tree fn_free_exception_tree = NULL_TREE;
static GTY (()) tree gm2_eh_int_type = NULL_TREE;
/* Modula-2 linker fodder. */
void
_M2_gm2except_init (void)
{
}
void
_M2_gm2except_finally (void)
{
}
/* InitExceptions - initialize this module, it declares the external
functions and assigns them to the appropriate global tree
variables. */
void
m2except_InitExceptions (location_t location)
{
tree t;
m2assert_AssertLocation (location);
m2block_pushGlobalScope ();
flag_exceptions = 1;
init_eh ();
m2decl_BuildStartFunctionDeclaration (FALSE);
fn_rethrow_tree = m2decl_BuildEndFunctionDeclaration (
location, location, "__cxa_rethrow", void_type_node, TRUE, FALSE, TRUE);
TREE_NOTHROW (fn_rethrow_tree) = 0;
m2decl_BuildStartFunctionDeclaration (FALSE);
m2decl_BuildParameterDeclaration (location, NULL, ptr_type_node, FALSE);
fn_begin_catch_tree = m2decl_BuildEndFunctionDeclaration (
location, location, "__cxa_begin_catch", ptr_type_node, TRUE, FALSE,
TRUE);
m2decl_BuildStartFunctionDeclaration (FALSE);
fn_end_catch_tree = m2decl_BuildEndFunctionDeclaration (
location, location, "__cxa_end_catch", void_type_node, TRUE, FALSE,
TRUE);
/* This can throw if the destructor for the exception throws. */
TREE_NOTHROW (fn_end_catch_tree) = 0;
/* The CLEANUP_TYPE is the internal type of a destructor. */
t = void_list_node;
t = tree_cons (NULL_TREE, ptr_type_node, t);
t = build_function_type (void_type_node, t);
cleanup_type = build_pointer_type (t);
/* Declare void __cxa_throw (void*, void*, void (*)(void*)). */
m2decl_BuildStartFunctionDeclaration (FALSE);
m2decl_BuildParameterDeclaration (location, NULL, cleanup_type, FALSE);
m2decl_BuildParameterDeclaration (location, NULL, ptr_type_node, FALSE);
m2decl_BuildParameterDeclaration (location, NULL, ptr_type_node, FALSE);
fn_throw_tree = m2decl_BuildEndFunctionDeclaration (
location, location, "__cxa_throw", void_type_node, TRUE, FALSE, TRUE);
/* Declare void __cxa_rethrow (void). */
m2decl_BuildStartFunctionDeclaration (FALSE);
fn_rethrow_tree = m2decl_BuildEndFunctionDeclaration (
location, location, "__cxa_rethrow", void_type_node, TRUE, FALSE, TRUE);
/* Declare void *__cxa_allocate_exception (size_t). */
m2decl_BuildStartFunctionDeclaration (FALSE);
m2decl_BuildParameterDeclaration (location, NULL, size_type_node, FALSE);
fn_allocate_exception_tree = m2decl_BuildEndFunctionDeclaration (
location, location, "__cxa_allocate_exception", ptr_type_node, TRUE,
FALSE, TRUE);
/* Declare void *__cxa_free_exception (void *). */
m2decl_BuildStartFunctionDeclaration (FALSE);
m2decl_BuildParameterDeclaration (location, NULL, ptr_type_node, FALSE);
fn_free_exception_tree = m2decl_BuildEndFunctionDeclaration (
location, location, "__cxa_free_exception", ptr_type_node, TRUE, FALSE,
TRUE);
/* Define integer type exception type which will match C++ int type
in the C++ runtime library. */
gm2_eh_int_type = build_eh_type_type (location, integer_type_node);
m2block_popGlobalScope ();
MARK_TS_TYPED (TRY_BLOCK);
MARK_TS_TYPED (THROW_EXPR);
MARK_TS_TYPED (HANDLER);
MARK_TS_TYPED (EXPR_STMT);
}
/* do_call0 - return a tree containing: call builtin_function (). */
static tree
do_call0 (location_t location, tree builtin_function)
{
tree function = build_address (builtin_function);
tree fntype = TREE_TYPE (TREE_TYPE (function));
tree result_type = TREE_TYPE (fntype);
m2assert_AssertLocation (location);
return build_call_array_loc (location, result_type, function, 0, NULL);
}
/* do_call1 - return a tree containing: call builtin_function
(param1). */
static tree
do_call1 (location_t location, tree builtin_function, tree param1)
{
tree *argarray = XALLOCAVEC (tree, 1);
tree function = build_address (builtin_function);
tree fntype = TREE_TYPE (TREE_TYPE (function));
tree result_type = TREE_TYPE (fntype);
m2assert_AssertLocation (location);
argarray[0] = param1;
return build_call_array_loc (location, result_type, function, 1, argarray);
}
/* do_call3 - return a tree containing: call builtin_function
(param1, param2, param3). */
static tree
do_call3 (location_t location, tree builtin_function, tree param1, tree param2,
tree param3)
{
tree *argarray = XALLOCAVEC (tree, 3);
tree function = build_address (builtin_function);
tree fntype = TREE_TYPE (TREE_TYPE (function));
tree result_type = TREE_TYPE (fntype);
m2assert_AssertLocation (location);
argarray[0] = param1;
argarray[1] = param2;
argarray[2] = param3;
return build_call_array_loc (location, result_type, function, 3, argarray);
}
/* build_exc_ptr - creates the GCC internal type, pointer to
exception control block. */
static tree
build_exc_ptr (location_t location)
{
m2assert_AssertLocation (location);
return do_call1 (location, builtin_decl_explicit (BUILT_IN_EH_POINTER),
integer_zero_node);
}
static tree
get_tinfo_decl_m2 (location_t location)
{
tree t = build_decl (location, VAR_DECL, get_identifier ("_ZTIi"),
ptr_type_node);
m2assert_AssertLocation (location);
TREE_STATIC (t) = 1;
DECL_EXTERNAL (t) = 1;
TREE_PUBLIC (t) = 1;
DECL_ARTIFICIAL (t) = 1;
DECL_IGNORED_P (t) = 1;
m2block_pushDecl (t);
make_decl_rtl (t);
return t;
}
/* Return the type info for TYPE as used by EH machinery. */
static tree
eh_type_info (location_t location, tree type)
{
m2assert_AssertLocation (location);
if (type == NULL_TREE || type == error_mark_node)
return type;
return get_tinfo_decl_m2 (location);
}
/* Return an ADDR_EXPR giving the address of T. This function
attempts no optimizations or simplifications; it is a low-level
primitive. */
static tree
build_address (tree t)
{
tree addr = build1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (t)), t);
return addr;
}
/* Build the address of a typeinfo decl for use in the runtime
matching field of the exception model. */
static tree
build_eh_type_type (location_t location, tree type)
{
tree exp = eh_type_info (location, type);
m2assert_AssertLocation (location);
if (!exp)
return NULL;
TREE_USED (exp) = 1;
return convert (ptr_type_node, build_address (exp));
}
/* Build a TARGET_EXPR, initializing the DECL with the VALUE. */
static tree
build_target_expr (tree decl, tree value)
{
tree t = build4 (TARGET_EXPR, TREE_TYPE (decl), decl, value, NULL_TREE,
NULL_TREE);
/* We always set TREE_SIDE_EFFECTS so that expand_expr does not
ignore the TARGET_EXPR. If there really turn out to be no
side-effects, then the optimizer should be able to get rid of
whatever code is generated anyhow. */
TREE_SIDE_EFFECTS (t) = 1;
return t;
}
/* Return an undeclared local temporary of type TYPE for use in
building a TARGET_EXPR. */
static tree
build_local_temp (location_t location, tree type)
{
tree slot = build_decl (location, VAR_DECL, NULL_TREE, type);
m2assert_AssertLocation (location);
DECL_ARTIFICIAL (slot) = 1;
DECL_IGNORED_P (slot) = 1;
DECL_CONTEXT (slot) = current_function_decl;
layout_decl (slot, 0);
return slot;
}
/* Build a TARGET_EXPR using INIT to initialize a new temporary of
the indicated TYPE. */
static tree
build_target_expr_with_type (location_t location, tree init, tree type)
{
tree slot;
m2assert_AssertLocation (location);
gcc_assert (!VOID_TYPE_P (type));
if (TREE_CODE (init) == TARGET_EXPR)
return init;
slot = build_local_temp (location, type);
return build_target_expr (slot, init);
}
/* Like build_target_expr_with_type, but use the type of INIT. */
static tree
get_target_expr (location_t location, tree init)
{
m2assert_AssertLocation (location);
return build_target_expr_with_type (location, init, TREE_TYPE (init));
}
/* do_allocate_exception - returns a tree which calls
allocate_exception (sizeof (type)); */
static tree
do_allocate_exception (location_t location, tree type)
{
return do_call1 (location, fn_allocate_exception_tree, size_in_bytes (type));
}
/* Call __cxa_free_exception from a cleanup. This is never invoked
directly, but see the comment for stabilize_throw_expr. */
static tree
do_free_exception (location_t location, tree ptr)
{
return do_call1 (location, fn_free_exception_tree, ptr);
}
/* do_throw - returns tree for a call to throw (ptr, gm2_eh_int_type,
0). */
static tree
do_throw (location_t location, tree ptr)
{
return do_call3 (location, fn_throw_tree, ptr,
unshare_expr (gm2_eh_int_type),
build_int_cst (cleanup_type, 0));
}
/* do_rethrow - returns a tree containing the call to rethrow (). */
static tree
do_rethrow (location_t location)
{
return do_call0 (location, fn_rethrow_tree);
}
/* gm2_build_throw - build a GCC throw expression tree which looks
identical to the C++ front end. */
static tree
gm2_build_throw (location_t location, tree exp)
{
m2assert_AssertLocation (location);
if (exp == NULL_TREE)
/* Rethrow the current exception. */
exp = build1 (THROW_EXPR, void_type_node, do_rethrow (location));
else
{
tree object, ptr;
tree allocate_expr;
tree tmp;
exp = m2expr_FoldAndStrip (
convert (m2type_GetIntegerType (), m2expr_FoldAndStrip (exp)));
exp = m2expr_GetIntegerOne (location);
/* Allocate the space for the exception. */
allocate_expr = do_allocate_exception (location, TREE_TYPE (exp));
allocate_expr = get_target_expr (location, allocate_expr);
ptr = TARGET_EXPR_SLOT (allocate_expr);
TARGET_EXPR_CLEANUP (allocate_expr) = do_free_exception (location, ptr);
CLEANUP_EH_ONLY (allocate_expr) = 1;
object = build1 (NOP_EXPR, build_pointer_type (TREE_TYPE (exp)), ptr);
object = m2expr_BuildIndirect (location, object, TREE_TYPE (exp));
/* And initialize the exception object. */
exp = build2 (INIT_EXPR, TREE_TYPE (object), object, exp);
/* Prepend the allocation. */
exp = build2 (COMPOUND_EXPR, TREE_TYPE (exp), allocate_expr, exp);
/* Force all the cleanups to be evaluated here so that we don't have
to do them during unwinding. */
exp = build1 (CLEANUP_POINT_EXPR, void_type_node, exp);
tmp = do_throw (location, ptr);
/* Tack on the initialization stuff. */
exp = build2 (COMPOUND_EXPR, TREE_TYPE (tmp), exp, tmp);
exp = build1 (THROW_EXPR, void_type_node, exp);
}
SET_EXPR_LOCATION (exp, location);
return exp;
}
/* gccgm2_BuildThrow - builds a throw expression and return the tree. */
tree
m2except_BuildThrow (location_t location, tree expr)
{
return gm2_build_throw (location, expr);
}
/* Build up a call to __cxa_begin_catch, to tell the runtime that the
exception has been handled. */
static tree
do_begin_catch (location_t location)
{
return do_call1 (location, fn_begin_catch_tree, build_exc_ptr (location));
}
/* Build up a call to __cxa_end_catch, to destroy the exception
object for the current catch block if no others are currently using
it. */
static tree
do_end_catch (location_t location)
{
tree cleanup = do_call0 (location, fn_end_catch_tree);
m2assert_AssertLocation (location);
TREE_NOTHROW (cleanup) = 1;
return cleanup;
}
/* BuildTryBegin - returns a tree representing the 'try' block. */
tree
m2except_BuildTryBegin (location_t location)
{
m2assert_AssertLocation (location);
return begin_try_block (location);
}
/* BuildTryEnd - builds the end of the Try block and prepares for the
catch handlers. */
void
m2except_BuildTryEnd (tree try_block)
{
TRY_STMTS (try_block) = m2block_pop_statement_list ();
TRY_STMTS (try_block) = m2block_end_statement_list (TRY_STMTS (try_block));
TRY_HANDLERS (try_block) = m2block_begin_statement_list ();
/* Now ensure that all successive add_stmts adds to this statement
sequence. */
m2block_push_statement_list (TRY_HANDLERS (try_block));
}
/* BuildCatchBegin - creates a handler tree for the C++ statement
'catch (...) {'. It returns the handler tree. */
tree
m2except_BuildCatchBegin (location_t location)
{
tree handler = begin_handler (location);
m2assert_AssertLocation (location);
return finish_handler_parms (location, handler);
}
/* BuildCatchEnd - completes a try catch block. It returns the,
try_block, tree. It creates the C++ statement
'}' which matches the catch above. */
tree
m2except_BuildCatchEnd (location_t location, tree handler, tree try_block)
{
m2assert_AssertLocation (location);
finish_handler (location, handler);
finish_handler_sequence (try_block);
return try_block;
}
/* Begin a handler. Returns a HANDLER if appropriate. */
static tree
begin_handler (location_t location)
{
tree r;
m2assert_AssertLocation (location);
r = build_stmt (location, HANDLER, NULL_TREE, NULL_TREE);
add_stmt (location, r);
HANDLER_BODY (r) = m2block_begin_statement_list ();
/* Now ensure that all successive add_stmts adds to this
statement sequence. */
m2block_push_statement_list (HANDLER_BODY (r));
return r;
}
/* Finish a handler, which may be given by HANDLER. The BLOCKs are
the return value from the matching call to finish_handler_parms. */
static void
finish_handler (location_t location, tree handler)
{
/* We might need to rethrow the exception if we reach the end.
use this code: finish_expr_stmt (build_throw (NULL_TREE)); */
tree body = m2block_pop_statement_list ();
m2assert_AssertLocation (location);
HANDLER_BODY (handler) = body;
m2block_end_statement_list (HANDLER_BODY (handler));
HANDLER_BODY (handler) = build2 (TRY_FINALLY_EXPR, void_type_node, body,
do_end_catch (location));
}
/* Finish the handler-parameters for a handler, which may be given by
HANDLER. */
static tree
finish_handler_parms (location_t location, tree handler)
{
m2assert_AssertLocation (location);
/* Equivalent to C++ catch (...). */
finish_expr_stmt (location, do_begin_catch (location));
HANDLER_TYPE (handler) = NULL_TREE;
return handler;
}
/* Finish a handler-sequence for a try-block, which may be given by
TRY_BLOCK. */
static void
finish_handler_sequence (tree try_block)
{
TRY_HANDLERS (try_block) = m2block_pop_statement_list ();
m2block_end_statement_list (TRY_HANDLERS (try_block));
}
/* Begin a try-block. Returns a newly-created TRY_BLOCK if
appropriate. */
static tree
begin_try_block (location_t location)
{
tree r = build_stmt (location, TRY_BLOCK, NULL_TREE, NULL_TREE);
m2assert_AssertLocation (location);
TRY_STMTS (r) = m2block_begin_statement_list ();
/* Now ensure that all successive add_stmts adds to this statement
sequence. */
m2block_push_statement_list (TRY_STMTS (r));
return r;
}
/* Finish an expression-statement, whose EXPRESSION is as indicated. */
static tree
finish_expr_stmt (location_t location, tree expr)
{
tree r = NULL_TREE;
m2assert_AssertLocation (location);
if (expr != NULL_TREE)
{
expr = build1 (CONVERT_EXPR, void_type_node, expr);
/* Simplification of inner statement expressions, compound exprs, etc
can result in us already having an EXPR_STMT. */
if (TREE_CODE (expr) != CLEANUP_POINT_EXPR)
{
if (TREE_CODE (expr) != EXPR_STMT)
expr = build_stmt (location, EXPR_STMT, expr);
expr = maybe_cleanup_point_expr_void (expr);
}
r = add_stmt (location, expr);
}
return r;
}
/* Like maybe_cleanup_point_expr except have the type of the new
expression be void so we don't need to create a temporary variable to
hold the inner expression. The reason why we do this is because the
original type might be an aggregate and we cannot create a temporary
variable for that type. */
static tree
maybe_cleanup_point_expr_void (tree expr)
{
return fold_build_cleanup_point_expr (void_type_node, expr);
}
#include "gt-m2-m2except.h"
-----------------------------
New file: gcc/m2/gm2-gcc/rtegraph.cc
-----------------------------
/* rtegraph.cc graph and nodes used by m2rte.
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/>. */
#include "gcc-consolidation.h"
#include "../gm2-lang.h"
#include "../m2-tree.h"
#include "langhooks-def.h" /* FIXME: for lhd_set_decl_assembler_name. */
#include "tree-pass.h" /* FIXME: only for PROP_gimple_any. */
#include "toplev.h"
#include "debug.h"
#include "opts.h"
#include "mpfr.h"
#undef DEBUGGING
struct GTY (()) rtenode
{
bool constructor_reachable; /* Is this guarenteed to be reachable by a constructor? */
bool export_reachable; /* Is this reachable via exported functions? */
bool exception_routine; /* Is this an exception routine? */
bool constructor_final; /* Have we walked this rtenode during constructor testing? */
bool export_final; /* Walked this rtenode during exported testing? */
bool is_call; /* Is this a function call? */
gimple *grtenode;
tree func;
rtenode *reachable_src; /* If this is reachable which src function will call us? */
vec<rtenode *, va_gc> *function_call;
vec<rtenode *, va_gc> *rts_call;
void dump (void);
void dump_vec (const char *title, vec<rtenode *, va_gc> *list);
void propagate_constructor_reachable (rtenode *);
void propagate_export_reachable (rtenode *);
void error_message (void);
void warning_message (void);
void note_message (void);
const char *get_func_name (void);
const char *create_message (const char *with_name, const char *without_name);
};
typedef vec<rtenode *, va_gc> rtevec;
static GTY (()) rtevec *allnodes;
static GTY (()) rtevec *candidates;
static GTY (()) rtevec *externs;
static GTY (()) rtevec *constructors;
static void determine_reachable (void);
static void issue_messages (void);
void rtegraph_dump (void);
static GTY (()) rtenode *rtegraph_current_function = NULL;
/* rtegraph_get_func returns the function associated with the rtenode. */
tree
rtegraph_get_func (rtenode *n)
{
return n->func;
}
/* rtegraph_set_current_function assigns rtegraph_current_function with func. */
void
rtegraph_set_current_function (rtenode *func)
{
rtegraph_current_function = func;
}
/* rtegraph_include_rtscall mark func as an exception routine and remember
that it is called from rtegraph_current_function in the rts_call array. */
void rtegraph_include_rtscall (rtenode *func)
{
/* This is a runtime exception, mark it as such. */
func->exception_routine = true;
/* And remember it. */
vec_safe_push (rtegraph_current_function->rts_call, func);
}
/* rtegraph_include_rtscall remember that rtegraph_current_function calls
func. */
void rtegraph_include_function_call (rtenode *func)
{
vec_safe_push (rtegraph_current_function->function_call, func);
}
/* rtegraph_discover performs the main work, called by m2rte.cc analyse_graph.
It determines which function calls a reachable and then issues any warning
message if a reachable function is a call to a runtime exception handler. */
void rtegraph_discover (void)
{
determine_reachable ();
#if defined (DEBUGGING)
rtegraph_dump ();
#endif
issue_messages ();
}
/* rtegraph_candidates_include include node n in the array of candidates. */
void rtegraph_candidates_include (rtenode *n)
{
unsigned int len = vec_safe_length (candidates);
for (unsigned int i = 0; i < len; i++)
if ((*candidates)[i] == n)
return;
vec_safe_push (candidates, n);
}
/* rtegraph_allnodes_include include node n in the array of allnodes. */
void rtegraph_allnodes_include (rtenode *n)
{
unsigned int len = vec_safe_length (allnodes);
for (unsigned int i = 0; i < len; i++)
if ((*allnodes)[i] == n)
return;
vec_safe_push (allnodes, n);
}
/* rtegraph_externs_include include node n in the array of externs. */
void rtegraph_externs_include (rtenode *n)
{
unsigned int len = vec_safe_length (externs);
for (unsigned int i = 0; i < len; i++)
if ((*externs)[i] == n)
return;
vec_safe_push (externs, n);
}
/* rtegraph_constructors_include include node n in the array of constructors. */
void rtegraph_constructors_include (rtenode *n)
{
unsigned int len = vec_safe_length (constructors);
for (unsigned int i = 0; i < len; i++)
if ((*constructors)[i] == n)
return;
vec_safe_push (constructors, n);
}
/* determine_reachable mark modules constructors as reachable and
also mark the exported functions as also reachable. */
void determine_reachable (void)
{
unsigned int len = vec_safe_length (constructors);
for (unsigned int i = 0; i < len; i++)
(*constructors)[i]->propagate_constructor_reachable ((*constructors)[i]);
len = vec_safe_length (externs);
for (unsigned int i = 0; i < len; i++)
(*externs)[i]->propagate_export_reachable ((*externs)[i]);
}
/* issue_messages for every candidate which is constructor reachable issue
an error. For each candidate which is reachable via an external call
issue a warning, for any other candidate (of a local procedure) issue
a note. */
void issue_messages (void)
{
unsigned int len = vec_safe_length (candidates);
for (unsigned int i = 0; i < len; i++)
{
if ((*candidates)[i]->constructor_reachable)
(*candidates)[i]->error_message ();
else if ((*candidates)[i]->export_reachable)
(*candidates)[i]->warning_message ();
else
(*candidates)[i]->note_message ();
}
}
#if defined (DEBUGGING)
/* rtegraph_dump_vec display the contents of a vector array. */
void
rtegraph_dump_vec (const char *title, vec<rtenode *, va_gc> *list)
{
unsigned int len = vec_safe_length (list);
printf ("%s (length = %d)\n", title, len);
for (unsigned int i = 0; i < len; i++)
{
printf ("[%d]: rtenode %p ", i, (*list)[i]);
(*list)[i]->dump ();
}
printf ("end\n");
}
/* rtegraph_dump display the contents of each vector array. */
void rtegraph_dump (void)
{
rtegraph_dump_vec ("allnodes", allnodes);
rtegraph_dump_vec ("candidates", candidates);
rtegraph_dump_vec ("externs", externs);
rtegraph_dump_vec ("constructors", constructors);
}
#endif
/* rtegraph_init_rtenode create and return a new rtenode. */
rtenode *
rtegraph_init_rtenode (gimple *g, tree fndecl, bool is_func_call)
{
rtenode *n = ggc_alloc<rtenode> ();
n->constructor_reachable = false;
n->export_reachable = false;
n->constructor_final = false;
n->export_final = false;
n->is_call = is_func_call;
n->grtenode = g;
n->func = fndecl;
n->reachable_src = NULL;
vec_alloc (n->function_call, 0);
// n->function_call = ggc_alloc<rtevec> ();
gcc_assert (vec_safe_length (n->function_call) == 0);
vec_alloc (n->rts_call, 0);
// n->rts_call = ggc_alloc<rtevec> ();
gcc_assert (vec_safe_length (n->rts_call) == 0);
return n;
}
/* rtegraph_lookup attempts to lookup a rtenode associated with a fndecl
which is a function call from node g. */
rtenode *
rtegraph_lookup (gimple *g, tree fndecl, bool is_call)
{
unsigned int len = vec_safe_length (allnodes);
for (unsigned int i = 0; i < len; i++)
if ((*allnodes)[i]->grtenode == g
&& (*allnodes)[i]->func == fndecl
&& (*allnodes)[i]->is_call == is_call)
return (*allnodes)[i];
rtenode *n = rtegraph_init_rtenode (g, fndecl, is_call);
vec_safe_push (allnodes, n);
#if defined (DEBUGGING)
rtegraph_dump ();
#endif
return n;
}
/* rte_error_at - wraps up an error message. */
static void
rte_error_at (location_t location, diagnostic_t kind, const char *message, ...)
{
diagnostic_info diagnostic;
va_list ap;
rich_location richloc (line_table, location);
va_start (ap, message);
diagnostic_set_info (&diagnostic, message, &ap, &richloc, kind);
diagnostic_report_diagnostic (global_dc, &diagnostic);
va_end (ap);
}
/* access_int return true if the tree t contains a constant integer, if so then
its value is assigned to *value. */
static bool
access_int (tree t, int *value)
{
enum tree_code code = TREE_CODE (t);
if (code == SSA_NAME)
return access_int (SSA_NAME_VAR (t), value);
if (code == INTEGER_CST)
{
*value = TREE_INT_CST_LOW (t);
return true;
}
if ((code == VAR_DECL || code == PARM_DECL)
&& DECL_HAS_VALUE_EXPR_P (t))
return access_int (DECL_VALUE_EXPR (t), value);
return false;
}
/* access_string return true if the tree t contains a constant string, if so then
its value is assigned to *value. */
static bool
access_string (tree t, const char **value)
{
if (TREE_CODE (t) == ADDR_EXPR)
{
if (TREE_CODE (TREE_OPERAND (t, 0)) == STRING_CST)
{
*value = TREE_STRING_POINTER (TREE_OPERAND (t, 0));
return true;
}
}
return false;
}
/* generate an error using the parameters of the M2RTS exception handler to
locate the source code. We dont use location, as the error_at function will
give the function context which might be misleading if this is inlined. */
static void
generate_report (gimple *stmt, const char *report, diagnostic_t kind)
{
if (gimple_call_num_args (stmt) == 5)
{
tree s0 = gimple_call_arg (stmt, 0);
tree i1 = gimple_call_arg (stmt, 1);
tree i2 = gimple_call_arg (stmt, 2);
tree s1 = gimple_call_arg (stmt, 3);
tree s2 = gimple_call_arg (stmt, 4);
const char *file;
int line;
int col;
const char *scope;
const char *message;
if (access_string (s0, &file)
&& access_int (i1, &line)
&& access_int (i2, &col)
&& access_string (s1, &scope)
&& access_string (s2, &message))
{
/* Continue to use scope as this will survive any
optimization transforms. */
location_t location = gimple_location (stmt);
rte_error_at (location, kind, "In %s\n%s, %s",
scope, report, message);
}
}
}
/* get_func_name returns the name of the function associated with rtenode. */
const char *rtenode::get_func_name (void)
{
if (func != NULL && (DECL_NAME (func) != NULL))
return IDENTIFIER_POINTER (DECL_NAME (func));
return NULL;
}
/* create_message if the current rtenode has a named function associated with it then
create a new message using with_name and the function name, otherwise
return without_name. */
const char *rtenode::create_message (const char *with_name, const char *without_name)
{
const char *name = get_func_name ();
if (name == NULL)
return without_name;
int len = strlen (with_name) + 1 + strlen (name);
char *message = XNEWVEC (char, len);
snprintf (message, len, with_name, name);
return message;
}
/* error_message issue an DK_ERROR from grtenode. */
void rtenode::error_message (void)
{
if (grtenode != NULL)
generate_report (grtenode, "runtime error will occur", DK_ERROR);
}
/* warning_message issue an DK_WARNING from grtenode. */
void rtenode::warning_message (void)
{
const char *message = reachable_src->create_message
("runtime error will occur if an exported procedure is called from %s",
"runtime error will occur if an exported procedure is called");
if (grtenode != NULL)
generate_report (grtenode, message, DK_WARNING);
}
/* note_message issue an DK_NOTE from grtenode. */
void rtenode::note_message (void)
{
if (grtenode != NULL)
generate_report (grtenode, "runtime will occur if this procedure is called", DK_NOTE);
}
/* dump_vec display contents of vector array list. */
#if defined (DEBUGGING)
void
rtenode::dump_vec (const char *title, vec<rtenode *, va_gc> *list)
{
printf (" %s (length = %d)\n", title, vec_safe_length (list));
for (unsigned int i = 0; i < vec_safe_length (list); i++)
printf (" [%d]: rtenode %p\n", i, (*list)[i]);
}
#endif
/* dump display all vector arrays associated with rtenode. */
void
rtenode::dump (void)
{
#if defined (DEBUGGING)
printf ("rtenode::dump:");
if (func != NULL && (DECL_NAME (func) != NULL))
{
const char *n = IDENTIFIER_POINTER (DECL_NAME (func));
printf ("%s", n);
}
if (constructor_reachable)
printf (", constructor_reachable");
if (export_reachable)
printf (", export_reachable");
if (constructor_final)
printf (", constructor_final");
if (export_final)
printf (", export_final");
if (is_call)
printf (", is_call");
else
printf (", decl");
printf (", grtenode %p, func = %p\n", grtenode, func);
dump_vec ("function_call", function_call);
dump_vec ("rts_call", rts_call);
#endif
}
/* propagate_constructor_reachable for every function which is reachable from
rtenode call the callee rtenode and mark it as reachable from a
constructor. */
void rtenode::propagate_constructor_reachable (rtenode *src)
{
if (constructor_final)
return;
constructor_final = true;
constructor_reachable = true;
reachable_src = src;
for (unsigned int i = 0; i < vec_safe_length (function_call); i++)
(*function_call)[i]->propagate_constructor_reachable (src);
for (unsigned int i = 0; i < vec_safe_length (rts_call); i++)
(*rts_call)[i]->propagate_constructor_reachable (src);
}
/* propagate_export_reachable for every function which is reachable
from rtenode call the callee rtenode and mark it as reachable from
an exported function. */
void rtenode::propagate_export_reachable (rtenode *src)
{
if (export_final)
return;
export_final = true;
export_reachable = true;
reachable_src = src;
for (unsigned int i = 0; i < vec_safe_length (function_call); i++)
(*function_call)[i]->propagate_export_reachable (src);
for (unsigned int i = 0; i < vec_safe_length (rts_call); i++)
(*rts_call)[i]->propagate_export_reachable (src);
}
/* rtegraph_init initialize the data structures (vec arrays) in this
file. */
void rtegraph_init (void)
{
vec_alloc (allnodes, 0);
gcc_assert (vec_safe_length (allnodes) == 0);
vec_alloc (candidates, 0);
gcc_assert (vec_safe_length (candidates) == 0);
vec_alloc (externs, 0);
gcc_assert (vec_safe_length (externs) == 0);
vec_alloc (constructors, 0);
gcc_assert (vec_safe_length (constructors) == 0);
#if defined (DEBUGGING)
rtegraph_dump ();
#endif
}
/* rtegraph_finish deallocate all vec arrays in this file. */
void rtegraph_finish (void)
{
rtegraph_current_function = NULL;
vec_free (allnodes);
vec_free (candidates);
vec_free (externs);
vec_free (constructors);
}
#include "gt-m2-rtegraph.h"
-----------------------------
New file: gcc/m2/gm2-gcc/m2statement.h
-----------------------------
/* m2statement.h header file for m2statement.cc.
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/>. */
#if !defined(m2statement_h)
#define m2statement_h
#if defined(m2statement_c)
#if defined(__GNUG__)
#define EXTERN extern "C"
#else /* !__GNUG__. */
#define EXTERN
#endif /* !__GNUG__. */
#else /* !m2statement_c. */
#if defined(__GNUG__)
#define EXTERN extern "C"
#else /* !__GNUG__. */
#define EXTERN extern
#endif /* !__GNUG__. */
#endif /* !m2statement_c. */
EXTERN void m2statement_BuildEndMainModule (void);
EXTERN void m2statement_BuildStartMainModule (void);
EXTERN void m2statement_BuildCallInner (location_t location, tree fndecl);
EXTERN void m2statement_BuildEnd (location_t location, tree fndecl,
int nested);
EXTERN tree m2statement_BuildStart (location_t location, char *name,
int inner_module);
EXTERN void m2statement_BuildIncludeVarVar (location_t location, tree type,
tree varset, tree varel,
int is_lvalue, tree low);
EXTERN void m2statement_BuildIncludeVarConst (location_t location, tree type,
tree op1, tree op2,
int is_lvalue, int fieldno);
EXTERN void m2statement_BuildExcludeVarVar (location_t location, tree type,
tree varset, tree varel,
int is_lvalue, tree low);
EXTERN void m2statement_BuildExcludeVarConst (location_t location, tree type,
tree op1, tree op2,
int is_lvalue, int fieldno);
EXTERN void m2statement_BuildUnaryForeachWordDo (
location_t location, tree type, tree op1, tree op2,
tree (*unop) (location_t, tree, int), int is_op1lvalue, int is_op2lvalue,
int is_op1const, int is_op2const);
EXTERN void m2statement_BuildAsm (location_t location, tree instr,
int isVolatile, int isSimple, tree inputs,
tree outputs, tree trash, tree labels);
EXTERN tree m2statement_BuildFunctValue (location_t location, tree value);
EXTERN tree m2statement_BuildIndirectProcedureCallTree (location_t location,
tree procedure,
tree rettype);
EXTERN tree m2statement_BuildProcedureCallTree (location_t location,
tree procedure, tree rettype);
EXTERN void m2statement_BuildFunctionCallTree (location_t location,
tree procedure, tree rettype);
EXTERN void m2statement_BuildParam (location_t location, tree param);
EXTERN tree m2statement_BuildIfThenElseEnd (tree condition, tree then_block,
tree else_block);
EXTERN tree m2statement_BuildIfThenDoEnd (tree condition, tree then_block);
EXTERN void m2statement_DeclareLabel (location_t location, char *name);
EXTERN void m2statement_BuildGoto (location_t location, char *name);
EXTERN tree m2statement_BuildAssignmentTree (location_t location, tree des,
tree expr);
EXTERN void m2statement_BuildAssignmentStatement (location_t location, tree des,
tree expr);
EXTERN void m2statement_BuildPopFunctionContext (void);
EXTERN void m2statement_BuildPushFunctionContext (void);
EXTERN void m2statement_BuildReturnValueCode (location_t location, tree fndecl,
tree value);
EXTERN void m2statement_BuildEndFunctionCode (location_t location, tree fndecl,
int nested);
EXTERN void m2statement_BuildStartFunctionCode (location_t location,
tree fndecl, int isexported,
int isinline);
EXTERN void m2statement_DoJump (location_t location, tree exp,
char *falselabel, char *truelabel);
EXTERN tree m2statement_BuildCall2 (location_t location, tree function,
tree rettype, tree arg1, tree arg2);
EXTERN tree m2statement_BuildCall3 (location_t location, tree function,
tree rettype, tree arg1, tree arg2,
tree arg3);
EXTERN void m2statement_SetLastFunction (tree t);
EXTERN tree m2statement_GetLastFunction (void);
EXTERN void m2statement_SetParamList (tree t);
EXTERN tree m2statement_GetParamList (void);
EXTERN tree m2statement_GetCurrentFunction (void);
EXTERN void m2statement_SetBeginLocation (location_t location);
EXTERN void m2statement_SetEndLocation (location_t location);
EXTERN tree m2statement_GetParamTree (tree call, unsigned int i);
EXTERN tree m2statement_BuildTryFinally (location_t location, tree call,
tree cleanups);
EXTERN tree m2statement_BuildCleanUp (tree param);
#undef EXTERN
#endif /* m2statement_h. */
-----------------------------
New file: gcc/m2/gm2-gcc/m2tree.cc
-----------------------------
/* m2tree.cc provides a simple interface to GCC tree queries and skips.
Copyright (C) 2012-2022 Free Software Foundation, Inc.
Contributed by Gaius Mulley <gaius@glam.ac.uk>.
This file is part of GNU Modula-2.
GNU Modula-2 is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 3, or (at your option)
any later version.
GNU Modula-2 is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
General Public License for more details.
You should have received a copy of the GNU General Public License
along with GNU Modula-2; see the file COPYING3. If not see
<http://www.gnu.org/licenses/>. */
#include "gcc-consolidation.h"
#include "../m2-tree.h"
#define m2tree_c
#include "m2tree.h"
int
m2tree_is_var (tree var)
{
return TREE_CODE (var) == VAR_DECL;
}
int
m2tree_is_array (tree array)
{
return TREE_CODE (array) == ARRAY_TYPE;
}
int
m2tree_is_type (tree type)
{
switch (TREE_CODE (type))
{
case TYPE_DECL:
case ARRAY_TYPE:
case RECORD_TYPE:
case SET_TYPE:
case ENUMERAL_TYPE:
case POINTER_TYPE:
case INTEGER_TYPE:
case REAL_TYPE:
case UNION_TYPE:
case BOOLEAN_TYPE:
case COMPLEX_TYPE:
return TRUE;
default:
return FALSE;
}
}
tree
m2tree_skip_type_decl (tree type)
{
if (type == error_mark_node)
return error_mark_node;
if (type == NULL_TREE)
return NULL_TREE;
if (TREE_CODE (type) == TYPE_DECL)
return m2tree_skip_type_decl (TREE_TYPE (type));
return type;
}
tree
m2tree_skip_const_decl (tree exp)
{
if (exp == error_mark_node)
return error_mark_node;
if (exp == NULL_TREE)
return NULL_TREE;
if (TREE_CODE (exp) == CONST_DECL)
return DECL_INITIAL (exp);
return exp;
}
/* m2tree_skip_reference_type - skips all POINTER_TYPE and
REFERENCE_TYPEs. Otherwise return exp. */
tree
m2tree_skip_reference_type (tree exp)
{
if (TREE_CODE (exp) == REFERENCE_TYPE)
return m2tree_skip_reference_type (TREE_TYPE (exp));
if (TREE_CODE (exp) == POINTER_TYPE)
return m2tree_skip_reference_type (TREE_TYPE (exp));
return exp;
}
/* m2tree_IsOrdinal - return TRUE if code is an INTEGER, BOOLEAN or
ENUMERAL type. */
int
m2tree_IsOrdinal (tree type)
{
enum tree_code code = TREE_CODE (type);
return (code == INTEGER_TYPE || (code) == BOOLEAN_TYPE
|| (code) == ENUMERAL_TYPE);
}
/* is_a_constant - returns TRUE if tree, t, is a constant. */
int
m2tree_IsAConstant (tree t)
{
return (TREE_CODE (t) == INTEGER_CST) || (TREE_CODE (t) == REAL_CST)
|| (TREE_CODE (t) == REAL_CST) || (TREE_CODE (t) == COMPLEX_CST)
|| (TREE_CODE (t) == STRING_CST);
}
void
m2tree_debug_tree (tree t)
{
debug_tree (t);
}
-----------------------------
New file: gcc/m2/gm2-gcc/m2type.cc
-----------------------------
/* m2type.cc provides an interface to GCC type trees.
Copyright (C) 2012-2022 Free Software Foundation, Inc.
Contributed by Gaius Mulley <gaius@glam.ac.uk>.
This file is part of GNU Modula-2.
GNU Modula-2 is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 3, or (at your option)
any later version.
GNU Modula-2 is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
General Public License for more details.
You should have received a copy of the GNU General Public License
along with GNU Modula-2; see the file COPYING3. If not see
<http://www.gnu.org/licenses/>. */
#include "gcc-consolidation.h"
#include "../gm2-lang.h"
#include "../m2-tree.h"
#define m2type_c
#include "m2assert.h"
#include "m2block.h"
#include "m2builtins.h"
#include "m2convert.h"
#include "m2decl.h"
#include "m2except.h"
#include "m2expr.h"
#include "m2linemap.h"
#include "m2tree.h"
#include "m2treelib.h"
#include "m2type.h"
#undef USE_BOOLEAN
static int broken_set_debugging_info = TRUE;
struct GTY (()) struct_constructor
{
/* Constructor_type, the type that we are constructing. */
tree GTY ((skip (""))) constructor_type;
/* Constructor_fields, the list of fields belonging to
constructor_type. Used by SET and RECORD constructors. */
tree GTY ((skip (""))) constructor_fields;
/* Constructor_element_list, the list of constants used by SET and
RECORD constructors. */
tree GTY ((skip (""))) constructor_element_list;
/* Constructor_elements, used by an ARRAY initializer all elements
are held in reverse order. */
vec<constructor_elt, va_gc> *constructor_elements;
/* Level, the next level down in the constructor stack. */
struct struct_constructor *level;
};
static GTY (()) struct struct_constructor *top_constructor = NULL;
typedef struct GTY (()) array_desc
{
int type;
tree index;
tree array;
struct array_desc *next;
} array_desc;
static GTY (()) array_desc *list_of_arrays = NULL;
/* Used in BuildStartFunctionType. */
static GTY (()) tree param_type_list;
static GTY (()) tree proc_type_node;
static GTY (()) tree bitset_type_node;
static GTY (()) tree bitnum_type_node;
static GTY (()) tree m2_char_type_node;
static GTY (()) tree m2_integer_type_node;
static GTY (()) tree m2_cardinal_type_node;
static GTY (()) tree m2_short_real_type_node;
static GTY (()) tree m2_real_type_node;
static GTY (()) tree m2_long_real_type_node;
static GTY (()) tree m2_long_int_type_node;
static GTY (()) tree m2_long_card_type_node;
static GTY (()) tree m2_short_int_type_node;
static GTY (()) tree m2_short_card_type_node;
static GTY (()) tree m2_z_type_node;
static GTY (()) tree m2_iso_loc_type_node;
static GTY (()) tree m2_iso_byte_type_node;
static GTY (()) tree m2_iso_word_type_node;
static GTY (()) tree m2_integer8_type_node;
static GTY (()) tree m2_integer16_type_node;
static GTY (()) tree m2_integer32_type_node;
static GTY (()) tree m2_integer64_type_node;
static GTY (()) tree m2_cardinal8_type_node;
static GTY (()) tree m2_cardinal16_type_node;
static GTY (()) tree m2_cardinal32_type_node;
static GTY (()) tree m2_cardinal64_type_node;
static GTY (()) tree m2_word16_type_node;
static GTY (()) tree m2_word32_type_node;
static GTY (()) tree m2_word64_type_node;
static GTY (()) tree m2_bitset8_type_node;
static GTY (()) tree m2_bitset16_type_node;
static GTY (()) tree m2_bitset32_type_node;
static GTY (()) tree m2_real32_type_node;
static GTY (()) tree m2_real64_type_node;
static GTY (()) tree m2_real96_type_node;
static GTY (()) tree m2_real128_type_node;
static GTY (()) tree m2_complex_type_node;
static GTY (()) tree m2_long_complex_type_node;
static GTY (()) tree m2_short_complex_type_node;
static GTY (()) tree m2_c_type_node;
static GTY (()) tree m2_complex32_type_node;
static GTY (()) tree m2_complex64_type_node;
static GTY (()) tree m2_complex96_type_node;
static GTY (()) tree m2_complex128_type_node;
static GTY (()) tree m2_packed_boolean_type_node;
static GTY (()) tree m2_cardinal_address_type_node;
/* gm2_canonicalize_array - returns a unique array node based on,
index_type, and, type. */
static tree
gm2_canonicalize_array (tree index_type, int type)
{
array_desc *l = list_of_arrays;
while (l != NULL)
{
if (l->type == type && l->index == index_type)
return l->array;
else
l = l->next;
}
l = ggc_alloc<array_desc> ();
l->next = list_of_arrays;
l->type = type;
l->index = index_type;
l->array = make_node (ARRAY_TYPE);
TREE_TYPE (l->array) = NULL_TREE;
TYPE_DOMAIN (l->array) = index_type;
list_of_arrays = l;
return l->array;
}
/* BuildStartArrayType - creates an array with an indextype and
elttype. The front end symbol, type, is also passed to allow the
gccgm2 to return the canonical edition of the array type even if
the GCC elttype is NULL_TREE. */
tree
m2type_BuildStartArrayType (tree index_type, tree elt_type, int type)
{
tree t;
elt_type = m2tree_skip_type_decl (elt_type);
ASSERT_CONDITION (index_type != NULL_TREE);
if (elt_type == NULL_TREE)
{
/* Cannot use GCC canonicalization routines yet, so we use our front
end version based on the front end type. */
return gm2_canonicalize_array (index_type, type);
}
t = gm2_canonicalize_array (index_type, type);
if (TREE_TYPE (t) == NULL_TREE)
TREE_TYPE (t) = elt_type;
else
ASSERT_CONDITION (TREE_TYPE (t) == elt_type);
return t;
}
/* PutArrayType - */
void
m2type_PutArrayType (tree array, tree type)
{
TREE_TYPE (array) = m2tree_skip_type_decl (type);
}
/* gccgm2_GetArrayNoOfElements - returns the number of elements in,
arraytype. */
tree
m2type_GetArrayNoOfElements (location_t location, tree arraytype)
{
tree index_type = TYPE_DOMAIN (m2tree_skip_type_decl (arraytype));
tree min = TYPE_MIN_VALUE (index_type);
tree max = TYPE_MAX_VALUE (index_type);
m2assert_AssertLocation (location);
return m2expr_FoldAndStrip (m2expr_BuildSub (location, max, min, FALSE));
}
/* gm2_finish_build_array_type - complete building the partially
created array type, arrayType. The arrayType is now known to be
declared as: ARRAY index_type OF elt_type. There will only ever
be one gcc tree type for this array definition. The third
parameter, type, is a front end type and this is necessary so that
the canonicalization creates unique array types for each type. */
static tree
gm2_finish_build_array_type (tree arrayType, tree elt_type, tree index_type,
int type)
{
tree old = arrayType;
elt_type = m2tree_skip_type_decl (elt_type);
ASSERT_CONDITION (index_type != NULL_TREE);
if (TREE_CODE (elt_type) == FUNCTION_TYPE)
{
error ("arrays of functions are not meaningful");
elt_type = integer_type_node;
}
TREE_TYPE (arrayType) = elt_type;
TYPE_DOMAIN (arrayType) = index_type;
arrayType = gm2_canonicalize_array (index_type, type);
if (arrayType != old)
internal_error ("array declaration canonicalization has failed");
if (!COMPLETE_TYPE_P (arrayType))
layout_type (arrayType);
return arrayType;
}
/* BuildEndArrayType - returns a type which is an array indexed by
IndexType and which has ElementType elements. */
tree
m2type_BuildEndArrayType (tree arraytype, tree elementtype, tree indextype,
int type)
{
elementtype = m2tree_skip_type_decl (elementtype);
ASSERT (indextype == TYPE_DOMAIN (arraytype), indextype);
if (TREE_CODE (elementtype) == FUNCTION_TYPE)
return gm2_finish_build_array_type (arraytype, ptr_type_node, indextype,
type);
else
return gm2_finish_build_array_type (
arraytype, m2tree_skip_type_decl (elementtype), indextype, type);
}
/* gm2_build_array_type - returns a type which is an array indexed by
IndexType and which has ElementType elements. */
static tree
gm2_build_array_type (tree elementtype, tree indextype, int fetype)
{
tree arrayType = m2type_BuildStartArrayType (indextype, elementtype, fetype);
return m2type_BuildEndArrayType (arrayType, elementtype, indextype, fetype);
}
/* ValueInTypeRange returns TRUE if the constant, value, lies within
the range of, type. */
int
m2type_ValueInTypeRange (tree type, tree value)
{
tree low_type = m2tree_skip_type_decl (type);
tree min_value = TYPE_MIN_VALUE (low_type);
tree max_value = TYPE_MAX_VALUE (low_type);
value = m2expr_FoldAndStrip (value);
return ((tree_int_cst_compare (min_value, value) <= 0)
&& (tree_int_cst_compare (value, max_value) <= 0));
}
/* ValueOutOfTypeRange returns TRUE if the constant, value, exceeds
the range of, type. */
int
m2type_ValueOutOfTypeRange (tree type, tree value)
{
return (!m2type_ValueInTypeRange (type, value));
}
/* ExceedsTypeRange return TRUE if low or high exceed the range of, type. */
int
m2type_ExceedsTypeRange (tree type, tree low, tree high)
{
return (m2type_ValueOutOfTypeRange (type, low)
|| m2type_ValueOutOfTypeRange (type, high));
}
/* WithinTypeRange return TRUE if low and high are within the range of, type.
*/
int
m2type_WithinTypeRange (tree type, tree low, tree high)
{
return (m2type_ValueInTypeRange (type, low)
&& m2type_ValueInTypeRange (type, high));
}
/* BuildArrayIndexType - creates an integer index which accesses an
array. low and high are the min, max elements of the array. GCC
insists we access an array with an integer indice. */
tree
m2type_BuildArrayIndexType (tree low, tree high)
{
tree sizelow = convert (m2type_GetIntegerType (), m2expr_FoldAndStrip (low));
tree sizehigh
= convert (m2type_GetIntegerType (), m2expr_FoldAndStrip (high));
if (m2expr_TreeOverflow (sizelow))
error ("low bound for the array is outside the ztype limits");
if (m2expr_TreeOverflow (sizehigh))
error ("high bound for the array is outside the ztype limits");
return build_range_type (m2type_GetIntegerType (),
m2expr_FoldAndStrip (sizelow),
m2expr_FoldAndStrip (sizehigh));
}
/* build_m2_type_node_by_array - builds a ISO Modula-2 word type from
ARRAY [low..high] OF arrayType. this matches the front end data
type, fetype, which is only used during canonicalization. */
static tree
build_m2_type_node_by_array (tree arrayType, tree low, tree high, int fetype)
{
return gm2_build_array_type (arrayType,
m2type_BuildArrayIndexType (low, high), fetype);
}
/* build_m2_word16_type_node - build an ISO 16 bit word as an ARRAY
[0..1] OF loc. */
static tree
build_m2_word16_type_node (location_t location, int loc)
{
return build_m2_type_node_by_array (m2type_GetISOLocType (),
m2expr_GetIntegerZero (location),
m2expr_GetIntegerOne (location), loc);
}
/* build_m2_word32_type_node - build an ISO 32 bit word as an ARRAY
[0..3] OF loc. */
static tree
build_m2_word32_type_node (location_t location, int loc)
{
return build_m2_type_node_by_array (m2type_GetISOLocType (),
m2expr_GetIntegerZero (location),
m2decl_BuildIntegerConstant (3), loc);
}
/* build_m2_word64_type_node - build an ISO 32 bit word as an ARRAY
[0..7] OF loc. */
static tree
build_m2_word64_type_node (location_t location, int loc)
{
return build_m2_type_node_by_array (m2type_GetISOLocType (),
m2expr_GetIntegerZero (location),
m2decl_BuildIntegerConstant (7), loc);
}
/* GetM2Complex32 - return the fixed size complex type. */
tree
m2type_GetM2Complex32 (void)
{
return m2_complex32_type_node;
}
/* GetM2Complex64 - return the fixed size complex type. */
tree
m2type_GetM2Complex64 (void)
{
return m2_complex64_type_node;
}
/* GetM2Complex96 - return the fixed size complex type. */
tree
m2type_GetM2Complex96 (void)
{
return m2_complex96_type_node;
}
/* GetM2Complex128 - return the fixed size complex type. */
tree
m2type_GetM2Complex128 (void)
{
return m2_complex128_type_node;
}
/* GetM2CType - a test function. */
tree
m2type_GetM2CType (void)
{
return m2_c_type_node;
}
/* GetM2ShortComplexType - return the short complex type. */
tree
m2type_GetM2ShortComplexType (void)
{
return m2_short_complex_type_node;
}
/* GetM2LongComplexType - return the long complex type. */
tree
m2type_GetM2LongComplexType (void)
{
return m2_long_complex_type_node;
}
/* GetM2ComplexType - return the complex type. */
tree
m2type_GetM2ComplexType (void)
{
return m2_complex_type_node;
}
/* GetM2Real128 - return the real 128 bit type. */
tree
m2type_GetM2Real128 (void)
{
return m2_real128_type_node;
}
/* GetM2Real96 - return the real 96 bit type. */
tree
m2type_GetM2Real96 (void)
{
return m2_real96_type_node;
}
/* GetM2Real64 - return the real 64 bit type. */
tree
m2type_GetM2Real64 (void)
{
return m2_real64_type_node;
}
/* GetM2Real32 - return the real 32 bit type. */
tree
m2type_GetM2Real32 (void)
{
return m2_real32_type_node;
}
/* GetM2Bitset32 - return the bitset 32 bit type. */
tree
m2type_GetM2Bitset32 (void)
{
return m2_bitset32_type_node;
}
/* GetM2Bitset16 - return the bitset 16 bit type. */
tree
m2type_GetM2Bitset16 (void)
{
return m2_bitset16_type_node;
}
/* GetM2Bitset8 - return the bitset 8 bit type. */
tree
m2type_GetM2Bitset8 (void)
{
return m2_bitset8_type_node;
}
/* GetM2Word64 - return the word 64 bit type. */
tree
m2type_GetM2Word64 (void)
{
return m2_word64_type_node;
}
/* GetM2Word32 - return the word 32 bit type. */
tree
m2type_GetM2Word32 (void)
{
return m2_word32_type_node;
}
/* GetM2Word16 - return the word 16 bit type. */
tree
m2type_GetM2Word16 (void)
{
return m2_word16_type_node;
}
/* GetM2Cardinal64 - return the cardinal 64 bit type. */
tree
m2type_GetM2Cardinal64 (void)
{
return m2_cardinal64_type_node;
}
/* GetM2Cardinal32 - return the cardinal 32 bit type. */
tree
m2type_GetM2Cardinal32 (void)
{
return m2_cardinal32_type_node;
}
/* GetM2Cardinal16 - return the cardinal 16 bit type. */
tree
m2type_GetM2Cardinal16 (void)
{
return m2_cardinal16_type_node;
}
/* GetM2Cardinal8 - return the cardinal 8 bit type. */
tree
m2type_GetM2Cardinal8 (void)
{
return m2_cardinal8_type_node;
}
/* GetM2Integer64 - return the integer 64 bit type. */
tree
m2type_GetM2Integer64 (void)
{
return m2_integer64_type_node;
}
/* GetM2Integer32 - return the integer 32 bit type. */
tree
m2type_GetM2Integer32 (void)
{
return m2_integer32_type_node;
}
/* GetM2Integer16 - return the integer 16 bit type. */
tree
m2type_GetM2Integer16 (void)
{
return m2_integer16_type_node;
}
/* GetM2Integer8 - return the integer 8 bit type. */
tree
m2type_GetM2Integer8 (void)
{
return m2_integer8_type_node;
}
/* GetM2RType - return the ISO R data type, the longest real
datatype. */
tree
m2type_GetM2RType (void)
{
return long_double_type_node;
}
/* GetM2ZType - return the ISO Z data type, the longest int datatype. */
tree
m2type_GetM2ZType (void)
{
return m2_z_type_node;
}
/* GetShortCardType - return the C short unsigned data type. */
tree
m2type_GetShortCardType (void)
{
return short_unsigned_type_node;
}
/* GetM2ShortCardType - return the m2 short cardinal data type. */
tree
m2type_GetM2ShortCardType (void)
{
return m2_short_card_type_node;
}
/* GetShortIntType - return the C short int data type. */
tree
m2type_GetShortIntType (void)
{
return short_integer_type_node;
}
/* GetM2ShortIntType - return the m2 short integer data type. */
tree
m2type_GetM2ShortIntType (void)
{
return m2_short_int_type_node;
}
/* GetM2LongCardType - return the m2 long cardinal data type. */
tree
m2type_GetM2LongCardType (void)
{
return m2_long_card_type_node;
}
/* GetM2LongIntType - return the m2 long integer data type. */
tree
m2type_GetM2LongIntType (void)
{
return m2_long_int_type_node;
}
/* GetM2LongRealType - return the m2 long real data type. */
tree
m2type_GetM2LongRealType (void)
{
return m2_long_real_type_node;
}
/* GetM2RealType - return the m2 real data type. */
tree
m2type_GetM2RealType (void)
{
return m2_real_type_node;
}
/* GetM2ShortRealType - return the m2 short real data type. */
tree
m2type_GetM2ShortRealType (void)
{
return m2_short_real_type_node;
}
/* GetM2CardinalType - return the m2 cardinal data type. */
tree
m2type_GetM2CardinalType (void)
{
return m2_cardinal_type_node;
}
/* GetM2IntegerType - return the m2 integer data type. */
tree
m2type_GetM2IntegerType (void)
{
return m2_integer_type_node;
}
/* GetM2CharType - return the m2 char data type. */
tree
m2type_GetM2CharType (void)
{
return m2_char_type_node;
}
/* GetProcType - return the m2 proc data type. */
tree
m2type_GetProcType (void)
{
return proc_type_node;
}
/* GetISOWordType - return the m2 iso word data type. */
tree
m2type_GetISOWordType (void)
{
return m2_iso_word_type_node;
}
/* GetISOByteType - return the m2 iso byte data type. */
tree
m2type_GetISOByteType (void)
{
return m2_iso_byte_type_node;
}
/* GetISOLocType - return the m2 loc word data type. */
tree
m2type_GetISOLocType (void)
{
return m2_iso_loc_type_node;
}
/* GetWordType - return the C unsigned data type. */
tree
m2type_GetWordType (void)
{
return unsigned_type_node;
}
/* GetLongIntType - return the C long int data type. */
tree
m2type_GetLongIntType (void)
{
return long_integer_type_node;
}
/* GetShortRealType - return the C float data type. */
tree
m2type_GetShortRealType (void)
{
return float_type_node;
}
/* GetLongRealType - return the C long double data type. */
tree
m2type_GetLongRealType (void)
{
return long_double_type_node;
}
/* GetRealType - returns the C double_type_node. */
tree
m2type_GetRealType (void)
{
return double_type_node;
}
/* GetBitnumType - return the ISO bitnum type. */
tree
m2type_GetBitnumType (void)
{
return bitnum_type_node;
}
/* GetBitsetType - return the bitset type. */
tree
m2type_GetBitsetType (void)
{
return bitset_type_node;
}
/* GetCardinalType - return the cardinal type. */
tree
m2type_GetCardinalType (void)
{
return unsigned_type_node;
}
/* GetPointerType - return the GCC ptr type node. Equivalent to
(void *). */
tree
m2type_GetPointerType (void)
{
return ptr_type_node;
}
/* GetVoidType - return the C void type. */
tree
m2type_GetVoidType (void)
{
return void_type_node;
}
/* GetByteType - return the byte type node. */
tree
m2type_GetByteType (void)
{
return unsigned_char_type_node;
}
/* GetCharType - return the char type node. */
tree
m2type_GetCharType (void)
{
return char_type_node;
}
/* GetIntegerType - return the integer type node. */
tree
m2type_GetIntegerType (void)
{
return integer_type_node;
}
/* GetCSizeTType - return a type representing, size_t on this system. */
tree
m2type_GetCSizeTType (void)
{
return sizetype;
}
/* GetCSSizeTType - return a type representing, size_t on this
system. */
tree
m2type_GetCSSizeTType (void)
{
return ssizetype;
}
/* GetPackedBooleanType - return the packed boolean data type node. */
tree
m2type_GetPackedBooleanType (void)
{
return m2_packed_boolean_type_node;
}
/* GetBooleanTrue - */
tree
m2type_GetBooleanTrue (void)
{
#if defined(USE_BOOLEAN)
return boolean_true_node;
#else /* !USE_BOOLEAN */
return m2expr_GetIntegerOne (m2linemap_BuiltinsLocation ());
#endif /* !USE_BOOLEAN */
}
/* GetBooleanFalse - */
tree
m2type_GetBooleanFalse (void)
{
#if defined(USE_BOOLEAN)
return boolean_false_node;
#else /* !USE_BOOLEAN */
return m2expr_GetIntegerZero (m2linemap_BuiltinsLocation ());
#endif /* !USE_BOOLEAN */
}
/* GetBooleanType - */
tree
m2type_GetBooleanType (void)
{
#if defined(USE_BOOLEAN)
return boolean_type_node;
#else /* !USE_BOOLEAN */
return integer_type_node;
#endif /* !USE_BOOLEAN */
}
/* GetCardinalAddressType - returns the internal data type for
computing binary arithmetic upon the ADDRESS datatype. */
tree
m2type_GetCardinalAddressType (void)
{
return m2_cardinal_address_type_node;
}
/* noBitsRequired - returns the number of bits required to contain,
values. How many bits are required to represent all numbers
between: 0..values-1 */
static tree
noBitsRequired (tree values)
{
int bits = tree_floor_log2 (values);
if (integer_pow2p (values))
/* remember we start counting from zero. */
return m2decl_BuildIntegerConstant (bits);
else
return m2decl_BuildIntegerConstant (bits + 1);
}
#if 0
/* build_set_type - creates a set type from the, domain, [low..high].
The values low..high all have type, range_type. */
static tree
build_set_type (tree domain, tree range_type, int allow_void, int ispacked)
{
tree type;
if (!m2tree_IsOrdinal (domain)
&& !(allow_void && TREE_CODE (domain) == VOID_TYPE))
{
error ("set base type must be an ordinal type");
return NULL;
}
if (TYPE_SIZE (range_type) == 0)
layout_type (range_type);
if (TYPE_SIZE (domain) == 0)
layout_type (domain);
type = make_node (SET_TYPE);
TREE_TYPE (type) = range_type;
TYPE_DOMAIN (type) = domain;
TYPE_PACKED (type) = ispacked;
return type;
}
/* convert_type_to_range - does the conversion and copies the range
type */
static tree
convert_type_to_range (tree type)
{
tree min, max;
tree itype;
if (!m2tree_IsOrdinal (type))
{
error ("ordinal type expected");
return error_mark_node;
}
min = TYPE_MIN_VALUE (type);
max = TYPE_MAX_VALUE (type);
if (TREE_TYPE (min) != TREE_TYPE (max))
{
error ("range limits are not of the same type");
return error_mark_node;
}
itype = build_range_type (TREE_TYPE (min), min, max);
if (TREE_TYPE (type) == NULL_TREE)
{
layout_type (type);
TREE_TYPE (itype) = type;
}
else
{
layout_type (TREE_TYPE (type));
TREE_TYPE (itype) = TREE_TYPE (type);
}
layout_type (itype);
return itype;
}
#endif
/* build_bitset_type - builds the type BITSET which is exported from
SYSTEM. It also builds BITNUM (the subrange from which BITSET is
created). */
static tree
build_bitset_type (location_t location)
{
m2assert_AssertLocation (location);
bitnum_type_node = build_range_type (
m2tree_skip_type_decl (m2type_GetCardinalType ()),
m2decl_BuildIntegerConstant (0),
m2decl_BuildIntegerConstant (m2decl_GetBitsPerBitset () - 1));
layout_type (bitnum_type_node);
#if 1
if (broken_set_debugging_info)
return unsigned_type_node;
#endif
ASSERT ((COMPLETE_TYPE_P (bitnum_type_node)), bitnum_type_node);
return m2type_BuildSetTypeFromSubrange (
location, NULL, bitnum_type_node, m2decl_BuildIntegerConstant (0),
m2decl_BuildIntegerConstant (m2decl_GetBitsPerBitset () - 1), FALSE);
}
/* BuildSetTypeFromSubrange constructs a set type from a
subrangeType. --fixme-- revisit once gdb/gcc supports dwarf-5 set type. */
tree
m2type_BuildSetTypeFromSubrange (location_t location,
char *name __attribute__ ((unused)),
tree subrangeType __attribute__ ((unused)),
tree lowval, tree highval, int ispacked)
{
m2assert_AssertLocation (location);
lowval = m2expr_FoldAndStrip (lowval);
highval = m2expr_FoldAndStrip (highval);
#if 0
if (broken_set_debugging_info)
return unsigned_type_node;
else
#endif
if (ispacked)
{
tree noelements = m2expr_BuildAdd (
location, m2expr_BuildSub (location, highval, lowval, FALSE),
integer_one_node, FALSE);
highval = m2expr_FoldAndStrip (m2expr_BuildSub (
location, m2expr_BuildLSL (location, m2expr_GetWordOne (location),
noelements, FALSE),
m2expr_GetIntegerOne (location), FALSE));
lowval = m2expr_GetIntegerZero (location);
return m2type_BuildSmallestTypeRange (location, lowval, highval);
}
else
return unsigned_type_node;
}
/* build_m2_size_set_type - build and return a set type with,
precision, bits. */
static tree
build_m2_size_set_type (location_t location, int precision)
{
tree bitnum_type_node
= build_range_type (m2tree_skip_type_decl (m2type_GetCardinalType ()),
m2decl_BuildIntegerConstant (0),
m2decl_BuildIntegerConstant (precision - 1));
layout_type (bitnum_type_node);
m2assert_AssertLocation (location);
if (broken_set_debugging_info)
return unsigned_type_node;
ASSERT ((COMPLETE_TYPE_P (bitnum_type_node)), bitnum_type_node);
return m2type_BuildSetTypeFromSubrange (
location, NULL, bitnum_type_node, m2decl_BuildIntegerConstant (0),
m2decl_BuildIntegerConstant (precision - 1), FALSE);
}
/* build_m2_specific_size_type - build a specific data type matching
number of bits, precision, whether it, is_signed. It creates a
set type if base == SET_TYPE or returns the already created real,
if REAL_TYPE is specified. */
static tree
build_m2_specific_size_type (location_t location, enum tree_code base,
int precision, int is_signed)
{
tree c;
m2assert_AssertLocation (location);
c = make_node (base);
TYPE_PRECISION (c) = precision;
if (base == REAL_TYPE)
{
if (!float_mode_for_size (TYPE_PRECISION (c)).exists ())
return NULL;
layout_type (c);
}
else if (base == SET_TYPE)
return build_m2_size_set_type (location, precision);
else
{
TYPE_SIZE (c) = 0;
if (is_signed)
{
fixup_signed_type (c);
TYPE_UNSIGNED (c) = FALSE;
}
else
{
fixup_unsigned_type (c);
TYPE_UNSIGNED (c) = TRUE;
}
}
return c;
}
/* BuildSmallestTypeRange - returns the smallest INTEGER_TYPE which
is sufficient to contain values: low..high. */
tree
m2type_BuildSmallestTypeRange (location_t location, tree low, tree high)
{
tree bits;
m2assert_AssertLocation (location);
low = fold (low);
high = fold (high);
bits = fold (noBitsRequired (
m2expr_BuildAdd (location, m2expr_BuildSub (location, high, low, FALSE),
m2expr_GetIntegerOne (location), FALSE)));
return build_m2_specific_size_type (location, INTEGER_TYPE,
TREE_INT_CST_LOW (bits),
tree_int_cst_sgn (low) < 0);
}
/* GetTreeType - returns TREE_TYPE (t). */
tree
m2type_GetTreeType (tree t)
{
return TREE_TYPE (t);
}
/* finish_build_pointer_type - finish building a POINTER_TYPE node.
necessary to solve self references in procedure types. */
/* Code taken from tree.cc:build_pointer_type_for_mode. */
static tree
finish_build_pointer_type (tree t, tree to_type, enum machine_mode mode,
bool can_alias_all)
{
TREE_TYPE (t) = to_type;
SET_TYPE_MODE (t, mode);
TYPE_REF_CAN_ALIAS_ALL (t) = can_alias_all;
TYPE_NEXT_PTR_TO (t) = TYPE_POINTER_TO (to_type);
TYPE_POINTER_TO (to_type) = t;
/* Lay out the type. */
/* layout_type (t); */
layout_type (t);
return t;
}
/* BuildParameterDeclaration - creates and returns one parameter
from, name, and, type. It appends this parameter to the internal
param_type_list. */
tree
m2type_BuildProcTypeParameterDeclaration (location_t location, tree type,
int isreference)
{
m2assert_AssertLocation (location);
ASSERT_BOOL (isreference);
type = m2tree_skip_type_decl (type);
if (isreference)
type = build_reference_type (type);
param_type_list = tree_cons (NULL_TREE, type, param_type_list);
return type;
}
/* BuildEndFunctionType - build a function type which would return a,
value. The arguments have been created by
BuildParameterDeclaration. */
tree
m2type_BuildEndFunctionType (tree func, tree return_type, int uses_varargs)
{
tree last;
if (return_type == NULL_TREE)
return_type = void_type_node;
else
return_type = m2tree_skip_type_decl (return_type);
if (uses_varargs)
{
if (param_type_list != NULL_TREE)
{
param_type_list = nreverse (param_type_list);
last = param_type_list;
param_type_list = nreverse (param_type_list);
gcc_assert (last != void_list_node);
}
}
else if (param_type_list == NULL_TREE)
param_type_list = void_list_node;
else
{
param_type_list = nreverse (param_type_list);
last = param_type_list;
param_type_list = nreverse (param_type_list);
TREE_CHAIN (last) = void_list_node;
}
param_type_list = build_function_type (return_type, param_type_list);
func = finish_build_pointer_type (func, param_type_list, ptr_mode, false);
TYPE_SIZE (func) = 0;
layout_type (func);
return func;
}
/* BuildStartFunctionType - creates a pointer type, necessary to
create a function type. */
tree
m2type_BuildStartFunctionType (location_t location ATTRIBUTE_UNUSED,
char *name ATTRIBUTE_UNUSED)
{
tree n = make_node (POINTER_TYPE);
m2assert_AssertLocation (location);
return n;
}
/* InitFunctionTypeParameters - resets the current function type
parameter list. */
void
m2type_InitFunctionTypeParameters (void)
{
param_type_list = NULL_TREE;
}
/* gm2_finish_decl - */
static void
gm2_finish_decl (location_t location, tree decl)
{
tree type = TREE_TYPE (decl);
int was_incomplete = (DECL_SIZE (decl) == 0);
m2assert_AssertLocation (location);
if (TREE_CODE (decl) == VAR_DECL)
{
if (DECL_SIZE (decl) == 0 && TREE_TYPE (decl) != error_mark_node
&& COMPLETE_TYPE_P (TREE_TYPE (decl)))
layout_decl (decl, 0);
if (DECL_SIZE (decl) == 0
/* Don't give an error if we already gave one earlier. */
&& TREE_TYPE (decl) != error_mark_node)
{
error_at (location, "storage size of %q+D isn%'t known", decl);
TREE_TYPE (decl) = error_mark_node;
}
if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
&& DECL_SIZE (decl) != 0)
{
if (TREE_CODE (DECL_SIZE (decl)) == INTEGER_CST)
m2expr_ConstantExpressionWarning (DECL_SIZE (decl));
else
error_at (location, "storage size of %q+D isn%'t constant", decl);
}
if (TREE_USED (type))
TREE_USED (decl) = 1;
}
/* Output the assembler code and/or RTL code for variables and
functions, unless the type is an undefined structure or union. If
not, it will get done when the type is completed. */
if (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL)
{
if (DECL_FILE_SCOPE_P (decl))
{
if (DECL_INITIAL (decl) == NULL_TREE
|| DECL_INITIAL (decl) == error_mark_node)
/* Don't output anything when a tentative file-scope definition is
seen. But at end of compilation, do output code for them. */
DECL_DEFER_OUTPUT (decl) = 1;
rest_of_decl_compilation (decl, true, 0);
}
if (!DECL_FILE_SCOPE_P (decl))
{
/* Recompute the RTL of a local array now if it used to be an
incomplete type. */
if (was_incomplete && !TREE_STATIC (decl) && !DECL_EXTERNAL (decl))
{
/* If we used it already as memory, it must stay in memory. */
TREE_ADDRESSABLE (decl) = TREE_USED (decl);
/* If it's still incomplete now, no init will save it. */
if (DECL_SIZE (decl) == 0)
DECL_INITIAL (decl) = 0;
}
}
}
if (TREE_CODE (decl) == TYPE_DECL)
{
if (!DECL_FILE_SCOPE_P (decl)
&& variably_modified_type_p (TREE_TYPE (decl), NULL_TREE))
m2block_pushDecl (build_stmt (location, DECL_EXPR, decl));
rest_of_decl_compilation (decl, DECL_FILE_SCOPE_P (decl), 0);
}
}
/* BuildVariableArrayAndDeclare - creates a variable length array.
high is the maximum legal elements (which is a runtime variable).
This creates and array index, array type and local variable. */
tree
m2type_BuildVariableArrayAndDeclare (location_t location, tree elementtype,
tree high, char *name, tree scope)
{
tree indextype = build_index_type (variable_size (high));
tree arraytype = build_array_type (elementtype, indextype);
tree id = get_identifier (name);
tree decl;
m2assert_AssertLocation (location);
decl = build_decl (location, VAR_DECL, id, arraytype);
DECL_EXTERNAL (decl) = FALSE;
TREE_PUBLIC (decl) = TRUE;
DECL_CONTEXT (decl) = scope;
TREE_USED (arraytype) = TRUE;
TREE_USED (decl) = TRUE;
m2block_pushDecl (decl);
gm2_finish_decl (location, indextype);
gm2_finish_decl (location, arraytype);
add_stmt (location, build_stmt (location, DECL_EXPR, decl));
return decl;
}
static tree
build_m2_iso_word_node (location_t location, int loc)
{
tree c;
m2assert_AssertLocation (location);
/* Define `WORD' as specified in ISO m2
WORD = ARRAY [0..SizeOfWord / SizeOfLoc] OF LOC ; */
if (m2decl_GetBitsPerInt () == BITS_PER_UNIT)
c = m2type_GetISOLocType ();
else
c = gm2_build_array_type (
m2type_GetISOLocType (),
m2type_BuildArrayIndexType (
m2expr_GetIntegerZero (location),
(m2expr_BuildSub (location,
m2decl_BuildIntegerConstant (
m2decl_GetBitsPerInt () / BITS_PER_UNIT),
m2expr_GetIntegerOne (location), FALSE))),
loc);
return c;
}
static tree
build_m2_iso_byte_node (location_t location, int loc)
{
tree c;
/* Define `BYTE' as specified in ISO m2
BYTE = ARRAY [0..SizeOfByte / SizeOfLoc] OF LOC ; */
if (BITS_PER_UNIT == 8)
c = m2type_GetISOLocType ();
else
c = gm2_build_array_type (
m2type_GetISOLocType (),
m2type_BuildArrayIndexType (
m2expr_GetIntegerZero (location),
m2decl_BuildIntegerConstant (BITS_PER_UNIT / 8)),
loc);
return c;
}
/* m2type_InitSystemTypes - initialise loc and word derivatives. */
void
m2type_InitSystemTypes (location_t location, int loc)
{
m2assert_AssertLocation (location);
m2_iso_word_type_node = build_m2_iso_word_node (location, loc);
m2_iso_byte_type_node = build_m2_iso_byte_node (location, loc);
m2_word16_type_node = build_m2_word16_type_node (location, loc);
m2_word32_type_node = build_m2_word32_type_node (location, loc);
m2_word64_type_node = build_m2_word64_type_node (location, loc);
}
static tree
build_m2_integer_node (void)
{
return m2type_GetIntegerType ();
}
static tree
build_m2_cardinal_node (void)
{
return m2type_GetCardinalType ();
}
static tree
build_m2_char_node (void)
{
tree c;
/* Define `CHAR', to be an unsigned char. */
c = make_unsigned_type (CHAR_TYPE_SIZE);
layout_type (c);
return c;
}
static tree
build_m2_short_real_node (void)
{
tree c;
/* Define `REAL'. */
c = make_node (REAL_TYPE);
TYPE_PRECISION (c) = FLOAT_TYPE_SIZE;
layout_type (c);
return c;
}
static tree
build_m2_real_node (void)
{
tree c;
/* Define `REAL'. */
c = make_node (REAL_TYPE);
TYPE_PRECISION (c) = DOUBLE_TYPE_SIZE;
layout_type (c);
return c;
}
static tree
build_m2_long_real_node (void)
{
tree c;
/* Define `LONGREAL'. */
c = make_node (REAL_TYPE);
TYPE_PRECISION (c) = LONG_DOUBLE_TYPE_SIZE;
layout_type (c);
return c;
}
static tree
build_m2_long_int_node (void)
{
tree c;
/* Define `LONGINT'. */
c = make_signed_type (LONG_LONG_TYPE_SIZE);
layout_type (c);
return c;
}
static tree
build_m2_long_card_node (void)
{
tree c;
/* Define `LONGCARD'. */
c = make_unsigned_type (LONG_LONG_TYPE_SIZE);
layout_type (c);
return c;
}
static tree
build_m2_short_int_node (void)
{
tree c;
/* Define `SHORTINT'. */
c = make_signed_type (SHORT_TYPE_SIZE);
layout_type (c);
return c;
}
static tree
build_m2_short_card_node (void)
{
tree c;
/* Define `SHORTCARD'. */
c = make_unsigned_type (SHORT_TYPE_SIZE);
layout_type (c);
return c;
}
static tree
build_m2_iso_loc_node (void)
{
tree c;
/* Define `LOC' as specified in ISO m2. */
c = make_node (INTEGER_TYPE);
TYPE_PRECISION (c) = BITS_PER_UNIT;
TYPE_SIZE (c) = 0;
fixup_unsigned_type (c);
TYPE_UNSIGNED (c) = 1;
return c;
}
static tree
build_m2_integer8_type_node (location_t location)
{
m2assert_AssertLocation (location);
return build_m2_specific_size_type (location, INTEGER_TYPE, 8, TRUE);
}
static tree
build_m2_integer16_type_node (location_t location)
{
m2assert_AssertLocation (location);
return build_m2_specific_size_type (location, INTEGER_TYPE, 16, TRUE);
}
static tree
build_m2_integer32_type_node (location_t location)
{
m2assert_AssertLocation (location);
return build_m2_specific_size_type (location, INTEGER_TYPE, 32, TRUE);
}
static tree
build_m2_integer64_type_node (location_t location)
{
m2assert_AssertLocation (location);
return build_m2_specific_size_type (location, INTEGER_TYPE, 64, TRUE);
}
static tree
build_m2_cardinal8_type_node (location_t location)
{
m2assert_AssertLocation (location);
return build_m2_specific_size_type (location, INTEGER_TYPE, 8, FALSE);
}
static tree
build_m2_cardinal16_type_node (location_t location)
{
m2assert_AssertLocation (location);
return build_m2_specific_size_type (location, INTEGER_TYPE, 16, FALSE);
}
static tree
build_m2_cardinal32_type_node (location_t location)
{
m2assert_AssertLocation (location);
return build_m2_specific_size_type (location, INTEGER_TYPE, 32, FALSE);
}
static tree
build_m2_cardinal64_type_node (location_t location)
{
m2assert_AssertLocation (location);
return build_m2_specific_size_type (location, INTEGER_TYPE, 64, FALSE);
}
static tree
build_m2_bitset8_type_node (location_t location)
{
m2assert_AssertLocation (location);
if (broken_set_debugging_info)
return build_m2_specific_size_type (location, INTEGER_TYPE, 8, FALSE);
else
return build_m2_specific_size_type (location, SET_TYPE, 8, FALSE);
}
static tree
build_m2_bitset16_type_node (location_t location)
{
m2assert_AssertLocation (location);
if (broken_set_debugging_info)
return build_m2_specific_size_type (location, INTEGER_TYPE, 16, FALSE);
else
return build_m2_specific_size_type (location, SET_TYPE, 16, FALSE);
}
static tree
build_m2_bitset32_type_node (location_t location)
{
m2assert_AssertLocation (location);
if (broken_set_debugging_info)
return build_m2_specific_size_type (location, INTEGER_TYPE, 32, FALSE);
else
return build_m2_specific_size_type (location, SET_TYPE, 32, FALSE);
}
static tree
build_m2_real32_type_node (location_t location)
{
m2assert_AssertLocation (location);
return build_m2_specific_size_type (location, REAL_TYPE, 32, TRUE);
}
static tree
build_m2_real64_type_node (location_t location)
{
m2assert_AssertLocation (location);
return build_m2_specific_size_type (location, REAL_TYPE, 64, TRUE);
}
static tree
build_m2_real96_type_node (location_t location)
{
m2assert_AssertLocation (location);
return build_m2_specific_size_type (location, REAL_TYPE, 96, TRUE);
}
static tree
build_m2_real128_type_node (location_t location)
{
m2assert_AssertLocation (location);
return build_m2_specific_size_type (location, REAL_TYPE, 128, TRUE);
}
static tree
build_m2_complex_type_from (tree scalar_type)
{
tree new_type;
if (scalar_type == NULL)
return NULL;
if (scalar_type == float_type_node)
return complex_float_type_node;
if (scalar_type == double_type_node)
return complex_double_type_node;
if (scalar_type == long_double_type_node)
return complex_long_double_type_node;
new_type = make_node (COMPLEX_TYPE);
TREE_TYPE (new_type) = scalar_type;
layout_type (new_type);
return new_type;
}
static tree
build_m2_complex_type_node (void)
{
return build_m2_complex_type_from (m2_real_type_node);
}
static tree
build_m2_long_complex_type_node (void)
{
return build_m2_complex_type_from (m2_long_real_type_node);
}
static tree
build_m2_short_complex_type_node (void)
{
return build_m2_complex_type_from (m2_short_real_type_node);
}
static tree
build_m2_complex32_type_node (void)
{
return build_m2_complex_type_from (m2_real32_type_node);
}
static tree
build_m2_complex64_type_node (void)
{
return build_m2_complex_type_from (m2_real64_type_node);
}
static tree
build_m2_complex96_type_node (void)
{
return build_m2_complex_type_from (m2_real96_type_node);
}
static tree
build_m2_complex128_type_node (void)
{
return build_m2_complex_type_from (m2_real128_type_node);
}
static tree
build_m2_cardinal_address_type_node (location_t location)
{
tree size = size_in_bytes (ptr_type_node);
int bits = TREE_INT_CST_LOW (size) * BITS_PER_UNIT;
return build_m2_specific_size_type (location, INTEGER_TYPE, bits, FALSE);
}
/* InitBaseTypes create the Modula-2 base types. */
void
m2type_InitBaseTypes (location_t location)
{
m2assert_AssertLocation (location);
m2block_init ();
ptr_type_node = build_pointer_type (void_type_node);
proc_type_node
= build_pointer_type (build_function_type (void_type_node, NULL_TREE));
bitset_type_node = build_bitset_type (location);
m2_char_type_node = build_m2_char_node ();
m2_integer_type_node = build_m2_integer_node ();
m2_cardinal_type_node = build_m2_cardinal_node ();
m2_short_real_type_node = build_m2_short_real_node ();
m2_real_type_node = build_m2_real_node ();
m2_long_real_type_node = build_m2_long_real_node ();
m2_long_int_type_node = build_m2_long_int_node ();
m2_long_card_type_node = build_m2_long_card_node ();
m2_short_int_type_node = build_m2_short_int_node ();
m2_short_card_type_node = build_m2_short_card_node ();
m2_z_type_node = build_m2_long_int_node ();
m2_integer8_type_node = build_m2_integer8_type_node (location);
m2_integer16_type_node = build_m2_integer16_type_node (location);
m2_integer32_type_node = build_m2_integer32_type_node (location);
m2_integer64_type_node = build_m2_integer64_type_node (location);
m2_cardinal8_type_node = build_m2_cardinal8_type_node (location);
m2_cardinal16_type_node = build_m2_cardinal16_type_node (location);
m2_cardinal32_type_node = build_m2_cardinal32_type_node (location);
m2_cardinal64_type_node = build_m2_cardinal64_type_node (location);
m2_bitset8_type_node = build_m2_bitset8_type_node (location);
m2_bitset16_type_node = build_m2_bitset16_type_node (location);
m2_bitset32_type_node = build_m2_bitset32_type_node (location);
m2_real32_type_node = build_m2_real32_type_node (location);
m2_real64_type_node = build_m2_real64_type_node (location);
m2_real96_type_node = build_m2_real96_type_node (location);
m2_real128_type_node = build_m2_real128_type_node (location);
m2_complex_type_node = build_m2_complex_type_node ();
m2_long_complex_type_node = build_m2_long_complex_type_node ();
m2_short_complex_type_node = build_m2_short_complex_type_node ();
m2_c_type_node = build_m2_long_complex_type_node ();
m2_complex32_type_node = build_m2_complex32_type_node ();
m2_complex64_type_node = build_m2_complex64_type_node ();
m2_complex96_type_node = build_m2_complex96_type_node ();
m2_complex128_type_node = build_m2_complex128_type_node ();
m2_iso_loc_type_node = build_m2_iso_loc_node ();
m2_cardinal_address_type_node
= build_m2_cardinal_address_type_node (location);
m2_packed_boolean_type_node = build_nonstandard_integer_type (1, TRUE);
m2builtins_init (location);
m2except_InitExceptions (location);
m2expr_init (location);
}
/* BuildStartType - given a, type, with a, name, return a GCC
declaration of this type. TYPE name = foo ;
the type, foo, maybe a partially created type (which has
yet to be 'gm2_finish_decl'ed). */
tree
m2type_BuildStartType (location_t location, char *name, tree type)
{
tree id = get_identifier (name);
tree decl, tem;
m2assert_AssertLocation (location);
ASSERT (m2tree_is_type (type), type);
type = m2tree_skip_type_decl (type);
decl = build_decl (location, TYPE_DECL, id, type);
tem = m2block_pushDecl (decl);
ASSERT (tem == decl, decl);
ASSERT (m2tree_is_type (decl), decl);
return tem;
}
/* BuildEndType - finish declaring, type, and return, type. */
tree
m2type_BuildEndType (location_t location, tree type)
{
m2assert_AssertLocation (location);
layout_type (TREE_TYPE (type));
gm2_finish_decl (location, type);
return type;
}
/* DeclareKnownType - given a, type, with a, name, return a GCC
declaration of this type. TYPE name = foo ; */
tree
m2type_DeclareKnownType (location_t location, char *name, tree type)
{
m2assert_AssertLocation (location);
return m2type_BuildEndType (location,
m2type_BuildStartType (location, name, type));
}
/* GetDefaultType - given a, type, with a, name, return a GCC
declaration of this type. Checks to see whether the type name has
already been declared as a default type and if so it returns this
declaration. Otherwise it declares the type. In Modula-2 this is
equivalent to:
TYPE name = type ;
We need this function during gm2 initialization as it allows
gm2 to access default types before creating Modula-2 types. */
tree
m2type_GetDefaultType (location_t location, char *name, tree type)
{
tree id = maybe_get_identifier (name);
m2assert_AssertLocation (location);
if (id == NULL)
{
tree prev = type;
tree t;
while (prev != NULL)
{
if (TYPE_NAME (prev) == NULL)
TYPE_NAME (prev) = get_identifier (name);
prev = TREE_TYPE (prev);
}
t = m2type_DeclareKnownType (location, name, type);
return t;
}
else
return id;
}
tree
do_min_real (tree type)
{
REAL_VALUE_TYPE r;
char buf[128];
enum machine_mode mode = TYPE_MODE (type);
get_max_float (REAL_MODE_FORMAT (mode), buf, sizeof (buf), false);
real_from_string (&r, buf);
return build1 (NEGATE_EXPR, type, build_real (type, r));
}
/* GetMinFrom - given a, type, return a constant representing the
minimum legal value. */
tree
m2type_GetMinFrom (location_t location, tree type)
{
m2assert_AssertLocation (location);
if (type == m2_real_type_node || type == m2type_GetRealType ())
return do_min_real (type);
if (type == m2_long_real_type_node || type == m2type_GetLongRealType ())
return do_min_real (type);
if (type == m2_short_real_type_node || type == m2type_GetShortRealType ())
return do_min_real (type);
if (type == ptr_type_node)
return m2expr_GetPointerZero (location);
return TYPE_MIN_VALUE (m2tree_skip_type_decl (type));
}
tree
do_max_real (tree type)
{
REAL_VALUE_TYPE r;
char buf[128];
enum machine_mode mode = TYPE_MODE (type);
get_max_float (REAL_MODE_FORMAT (mode), buf, sizeof (buf), false);
real_from_string (&r, buf);
return build_real (type, r);
}
/* GetMaxFrom - given a, type, return a constant representing the
maximum legal value. */
tree
m2type_GetMaxFrom (location_t location, tree type)
{
m2assert_AssertLocation (location);
if (type == m2_real_type_node || type == m2type_GetRealType ())
return do_max_real (type);
if (type == m2_long_real_type_node || type == m2type_GetLongRealType ())
return do_max_real (type);
if (type == m2_short_real_type_node || type == m2type_GetShortRealType ())
return do_max_real (type);
if (type == ptr_type_node)
return fold (m2expr_BuildSub (location, m2expr_GetPointerZero (location),
m2expr_GetPointerOne (location), FALSE));
return TYPE_MAX_VALUE (m2tree_skip_type_decl (type));
}
/* BuildTypeDeclaration - adds the, type, to the current statement
list. */
void
m2type_BuildTypeDeclaration (location_t location, tree type)
{
enum tree_code code = TREE_CODE (type);
m2assert_AssertLocation (location);
if (code == TYPE_DECL || code == RECORD_TYPE || code == POINTER_TYPE)
{
m2block_pushDecl (build_decl (location, TYPE_DECL, NULL, type));
}
else if (code == VAR_DECL)
{
m2type_BuildTypeDeclaration (location, TREE_TYPE (type));
m2block_pushDecl (
build_stmt (location, DECL_EXPR,
type)); /* Is this safe? --fixme--. */
}
}
/* Begin compiling the definition of an enumeration type. NAME is
its name (or null if anonymous). Returns the type object, as yet
incomplete. Also records info about it so that build_enumerator may
be used to declare the individual values as they are read. */
static tree
gm2_start_enum (location_t location, tree name, int ispacked)
{
tree enumtype = make_node (ENUMERAL_TYPE);
m2assert_AssertLocation (location);
if (TYPE_VALUES (enumtype) != 0)
{
/* This enum is a named one that has been declared already. */
error_at (location, "redeclaration of enum %qs",
IDENTIFIER_POINTER (name));
/* Completely replace its old definition. The old enumerators remain
defined, however. */
TYPE_VALUES (enumtype) = 0;
}
TYPE_PACKED (enumtype) = ispacked;
TREE_TYPE (enumtype) = m2type_GetIntegerType ();
/* This is required as rest_of_type_compilation will use this field
when called from gm2_finish_enum.
Create a fake NULL-named TYPE_DECL node whose TREE_TYPE will be the
tagged type we just added to the current scope. This fake NULL-named
TYPE_DECL node helps dwarfout.cc to know when it needs to output a
representation of a tagged type, and it also gives us a convenient
place to record the "scope start" address for the tagged type. */
TYPE_STUB_DECL (enumtype) = m2block_pushDecl (
build_decl (location, TYPE_DECL, NULL_TREE, enumtype));
return enumtype;
}
/* After processing and defining all the values of an enumeration
type, install their decls in the enumeration type and finish it off.
ENUMTYPE is the type object, VALUES a list of decl-value pairs, and
ATTRIBUTES are the specified attributes. Returns ENUMTYPE. */
static tree
gm2_finish_enum (location_t location, tree enumtype, tree values)
{
tree pair, tem;
tree minnode = 0, maxnode = 0;
int precision;
signop sign;
/* Calculate the maximum value of any enumerator in this type. */
if (values == error_mark_node)
minnode = maxnode = integer_zero_node;
else
{
minnode = maxnode = TREE_VALUE (values);
for (pair = TREE_CHAIN (values); pair; pair = TREE_CHAIN (pair))
{
tree value = TREE_VALUE (pair);
if (tree_int_cst_lt (maxnode, value))
maxnode = value;
if (tree_int_cst_lt (value, minnode))
minnode = value;
}
}
/* Construct the final type of this enumeration. It is the same as
one of the integral types - the narrowest one that fits, except that
normally we only go as narrow as int - and signed iff any of the
values are negative. */
sign = (tree_int_cst_sgn (minnode) >= 0) ? UNSIGNED : SIGNED;
precision = MAX (tree_int_cst_min_precision (minnode, sign),
tree_int_cst_min_precision (maxnode, sign));
if (precision > TYPE_PRECISION (integer_type_node))
{
warning (0, "enumeration values exceed range of integer");
tem = long_long_integer_type_node;
}
else if (TYPE_PACKED (enumtype))
tem = m2type_BuildSmallestTypeRange (location, minnode, maxnode);
else
tem = sign == UNSIGNED ? unsigned_type_node : integer_type_node;
TYPE_MIN_VALUE (enumtype) = TYPE_MIN_VALUE (tem);
TYPE_MAX_VALUE (enumtype) = TYPE_MAX_VALUE (tem);
TYPE_UNSIGNED (enumtype) = TYPE_UNSIGNED (tem);
TYPE_SIZE (enumtype) = 0;
/* If the precision of the type was specific with an attribute and it
was too small, give an error. Otherwise, use it. */
if (TYPE_PRECISION (enumtype))
{
if (precision > TYPE_PRECISION (enumtype))
error ("specified mode too small for enumerated values");
}
else
TYPE_PRECISION (enumtype) = TYPE_PRECISION (tem);
layout_type (enumtype);
if (values != error_mark_node)
{
/* Change the type of the enumerators to be the enum type. We need
to do this irrespective of the size of the enum, for proper type
checking. Replace the DECL_INITIALs of the enumerators, and the
value slots of the list, with copies that have the enum type; they
cannot be modified in place because they may be shared (e.g.
integer_zero_node) Finally, change the purpose slots to point to the
names of the decls. */
for (pair = values; pair; pair = TREE_CHAIN (pair))
{
tree enu = TREE_PURPOSE (pair);
tree ini = DECL_INITIAL (enu);
TREE_TYPE (enu) = enumtype;
if (TREE_TYPE (ini) != integer_type_node)
ini = convert (enumtype, ini);
DECL_INITIAL (enu) = ini;
TREE_PURPOSE (pair) = DECL_NAME (enu);
TREE_VALUE (pair) = ini;
}
TYPE_VALUES (enumtype) = values;
}
/* Fix up all variant types of this enum type. */
for (tem = TYPE_MAIN_VARIANT (enumtype); tem; tem = TYPE_NEXT_VARIANT (tem))
{
if (tem == enumtype)
continue;
TYPE_VALUES (tem) = TYPE_VALUES (enumtype);
TYPE_MIN_VALUE (tem) = TYPE_MIN_VALUE (enumtype);
TYPE_MAX_VALUE (tem) = TYPE_MAX_VALUE (enumtype);
TYPE_SIZE (tem) = TYPE_SIZE (enumtype);
TYPE_SIZE_UNIT (tem) = TYPE_SIZE_UNIT (enumtype);
SET_TYPE_MODE (tem, TYPE_MODE (enumtype));
TYPE_PRECISION (tem) = TYPE_PRECISION (enumtype);
SET_TYPE_ALIGN (tem, TYPE_ALIGN (enumtype));
TYPE_USER_ALIGN (tem) = TYPE_USER_ALIGN (enumtype);
TYPE_UNSIGNED (tem) = TYPE_UNSIGNED (enumtype);
TYPE_LANG_SPECIFIC (tem) = TYPE_LANG_SPECIFIC (enumtype);
}
/* Finish debugging output for this type. */
rest_of_type_compilation (enumtype, m2block_toplevel ());
return enumtype;
}
/* BuildStartEnumeration - create an enumerated type in gcc. */
tree
m2type_BuildStartEnumeration (location_t location, char *name, int ispacked)
{
tree id;
m2assert_AssertLocation (location);
if ((name == NULL) || (strcmp (name, "") == 0))
id = NULL_TREE;
else
id = get_identifier (name);
return gm2_start_enum (location, id, ispacked);
}
/* BuildEndEnumeration - finish building the enumeration, it uses the
enum list, enumvalues, and returns a enumeration type tree. */
tree
m2type_BuildEndEnumeration (location_t location, tree enumtype,
tree enumvalues)
{
tree finished ATTRIBUTE_UNUSED
= gm2_finish_enum (location, enumtype, enumvalues);
return enumtype;
}
/* Build and install a CONST_DECL for one value of the current
enumeration type (one that was begun with start_enum). Return a
tree-list containing the CONST_DECL and its value. Assignment of
sequential values by default is handled here. */
static tree
gm2_build_enumerator (location_t location, tree name, tree value)
{
tree decl, type;
m2assert_AssertLocation (location);
/* Remove no-op casts from the value. */
if (value)
STRIP_TYPE_NOPS (value);
/* Now create a declaration for the enum value name. */
type = TREE_TYPE (value);
decl = build_decl (location, CONST_DECL, name, type);
DECL_INITIAL (decl) = convert (type, value);
m2block_pushDecl (decl);
return tree_cons (decl, value, NULL_TREE);
}
/* BuildEnumerator - build an enumerator and add it to the,
enumvalues, list. It returns a copy of the value. --fixme-- why
do this? */
tree
m2type_BuildEnumerator (location_t location, char *name, tree value,
tree *enumvalues)
{
tree id = get_identifier (name);
tree copy_of_value = copy_node (value);
tree gccenum = gm2_build_enumerator (location, id, copy_of_value);
m2assert_AssertLocation (location);
/* Choose copy_of_value for enum value. */
*enumvalues = chainon (gccenum, *enumvalues);
return copy_of_value;
}
/* BuildPointerType - returns a type which is a pointer to, totype. */
tree
m2type_BuildPointerType (tree totype)
{
return build_pointer_type (m2tree_skip_type_decl (totype));
}
/* BuildConstPointerType - returns a type which is a const pointer
to, totype. */
tree
m2type_BuildConstPointerType (tree totype)
{
tree t = build_pointer_type (m2tree_skip_type_decl (totype));
TYPE_READONLY (t) = TRUE;
return t;
}
/* BuildSetType - creates a SET OF [lowval..highval]. */
tree
m2type_BuildSetType (location_t location, char *name, tree type, tree lowval,
tree highval, int ispacked)
{
tree range = build_range_type (m2tree_skip_type_decl (type),
m2expr_FoldAndStrip (lowval),
m2expr_FoldAndStrip (highval));
TYPE_PACKED (range) = ispacked;
m2assert_AssertLocation (location);
return m2type_BuildSetTypeFromSubrange (location, name, range,
m2expr_FoldAndStrip (lowval),
m2expr_FoldAndStrip (highval),
ispacked);
}
/* push_constructor - returns a new compound constructor frame. */
static struct struct_constructor *
push_constructor (void)
{
struct struct_constructor *p = ggc_alloc<struct_constructor> ();
p->level = top_constructor;
top_constructor = p;
return p;
}
/* pop_constructor - throws away the top constructor frame on the
stack. */
static void
pop_constructor (struct struct_constructor *p)
{
ASSERT_CONDITION (p
== top_constructor); /* p should be the top_constructor. */
top_constructor = top_constructor->level;
}
/* BuildStartSetConstructor - starts to create a set constant.
Remember that type is really a record type. */
void *
m2type_BuildStartSetConstructor (tree type)
{
struct struct_constructor *p = push_constructor ();
type = m2tree_skip_type_decl (type);
layout_type (type);
p->constructor_type = type;
p->constructor_fields = TYPE_FIELDS (type);
p->constructor_element_list = NULL_TREE;
vec_alloc (p->constructor_elements, 1);
return (void *)p;
}
/* BuildSetConstructorElement - adds, value, to the
constructor_element_list. */
void
m2type_BuildSetConstructorElement (void *p, tree value)
{
struct struct_constructor *c = (struct struct_constructor *)p;
if (value == NULL_TREE)
{
internal_error ("set type cannot be initialized with a %qs",
"NULL_TREE");
return;
}
if (c->constructor_fields == NULL)
{
internal_error ("set type does not take another integer value");
return;
}
c->constructor_element_list
= tree_cons (c->constructor_fields, value, c->constructor_element_list);
c->constructor_fields = TREE_CHAIN (c->constructor_fields);
}
/* BuildEndSetConstructor - finishes building a set constant. */
tree
m2type_BuildEndSetConstructor (void *p)
{
tree constructor;
tree link;
struct struct_constructor *c = (struct struct_constructor *)p;
for (link = c->constructor_element_list; link; link = TREE_CHAIN (link))
{
tree field = TREE_PURPOSE (link);
DECL_SIZE (field) = bitsize_int (SET_WORD_SIZE);
DECL_BIT_FIELD (field) = 1;
}
constructor = build_constructor_from_list (
c->constructor_type, nreverse (c->constructor_element_list));
TREE_CONSTANT (constructor) = 1;
TREE_STATIC (constructor) = 1;
pop_constructor (c);
return constructor;
}
/* BuildStartRecordConstructor - initializes a record compound
constructor frame. */
void *
m2type_BuildStartRecordConstructor (tree type)
{
struct struct_constructor *p = push_constructor ();
type = m2tree_skip_type_decl (type);
layout_type (type);
p->constructor_type = type;
p->constructor_fields = TYPE_FIELDS (type);
p->constructor_element_list = NULL_TREE;
vec_alloc (p->constructor_elements, 1);
return (void *)p;
}
/* BuildEndRecordConstructor - returns a tree containing the record
compound literal. */
tree
m2type_BuildEndRecordConstructor (void *p)
{
struct struct_constructor *c = (struct struct_constructor *)p;
tree constructor = build_constructor_from_list (
c->constructor_type, nreverse (c->constructor_element_list));
TREE_CONSTANT (constructor) = 1;
TREE_STATIC (constructor) = 1;
pop_constructor (c);
return constructor;
}
/* BuildRecordConstructorElement - adds, value, to the
constructor_element_list. */
void
m2type_BuildRecordConstructorElement (void *p, tree value)
{
m2type_BuildSetConstructorElement (p, value);
}
/* BuildStartArrayConstructor - initializes an array compound
constructor frame. */
void *
m2type_BuildStartArrayConstructor (tree type)
{
struct struct_constructor *p = push_constructor ();
type = m2tree_skip_type_decl (type);
layout_type (type);
p->constructor_type = type;
p->constructor_fields = TREE_TYPE (type);
p->constructor_element_list = NULL_TREE;
vec_alloc (p->constructor_elements, 1);
return (void *)p;
}
/* BuildEndArrayConstructor - returns a tree containing the array
compound literal. */
tree
m2type_BuildEndArrayConstructor (void *p)
{
struct struct_constructor *c = (struct struct_constructor *)p;
tree constructor;
constructor
= build_constructor (c->constructor_type, c->constructor_elements);
TREE_CONSTANT (constructor) = TRUE;
TREE_STATIC (constructor) = TRUE;
pop_constructor (c);
return constructor;
}
/* BuildArrayConstructorElement - adds, value, to the
constructor_element_list. */
void
m2type_BuildArrayConstructorElement (void *p, tree value, tree indice)
{
struct struct_constructor *c = (struct struct_constructor *)p;
constructor_elt celt;
if (value == NULL_TREE)
{
internal_error ("array cannot be initialized with a %qs", "NULL_TREE");
return;
}
if (c->constructor_fields == NULL_TREE)
{
internal_error ("array type must be initialized");
return;
}
if (c->constructor_fields != TREE_TYPE (value))
{
internal_error (
"array element value must be the same type as its declaration");
return;
}
celt.index = indice;
celt.value = value;
vec_safe_push (c->constructor_elements, celt);
}
/* BuildArrayStringConstructor - creates an array constructor for,
arrayType, consisting of the character elements defined by, str,
of, length, characters. */
tree
m2type_BuildArrayStringConstructor (location_t location, tree arrayType,
tree str, tree length)
{
tree n;
tree val;
int i = 0;
const char *p = TREE_STRING_POINTER (str);
tree type = m2tree_skip_type_decl (TREE_TYPE (arrayType));
struct struct_constructor *c
= (struct struct_constructor *)m2type_BuildStartArrayConstructor (
arrayType);
char nul[1];
int len = strlen (p);
nul[0] = (char)0;
m2assert_AssertLocation (location);
n = m2expr_GetIntegerZero (location);
while (m2expr_CompareTrees (n, length) < 0)
{
if (i < len)
val = m2convert_BuildConvert (
location, type, m2type_BuildCharConstant (location, &p[i]), FALSE);
else
val = m2type_BuildCharConstant (location, &nul[0]);
m2type_BuildArrayConstructorElement (c, val, n);
i += 1;
n = m2expr_BuildAdd (location, n, m2expr_GetIntegerOne (location),
FALSE);
}
return m2type_BuildEndArrayConstructor (c);
}
/* BuildSubrangeType - creates a subrange of, type, with, lowval,
highval. */
tree
m2type_BuildSubrangeType (location_t location, char *name, tree type,
tree lowval, tree highval)
{
tree range_type;
m2assert_AssertLocation (location);
type = m2tree_skip_type_decl (type);
lowval = m2expr_FoldAndStrip (lowval);
highval = m2expr_FoldAndStrip (highval);
if (m2expr_TreeOverflow (lowval))
error ("low bound for the subrange has overflowed");
if (m2expr_TreeOverflow (highval))
error ("high bound for the subrange has overflowed");
/* First build a type with the base range. */
range_type = build_range_type (type, TYPE_MIN_VALUE (type),
TYPE_MAX_VALUE (type));
TYPE_UNSIGNED (range_type) = TYPE_UNSIGNED (type);
#if 0
/* Then set the actual range. */
SET_TYPE_RM_MIN_VALUE (range_type, lowval);
SET_TYPE_RM_MAX_VALUE (range_type, highval);
#endif
if ((name != NULL) && (strcmp (name, "") != 0))
{
/* Declared as TYPE foo = [x..y]; */
range_type = m2type_DeclareKnownType (location, name, range_type);
layout_type (m2tree_skip_type_decl (range_type));
}
return range_type;
}
/* BuildCharConstantChar - creates a character constant given a character, ch. */
tree
m2type_BuildCharConstantChar (location_t location, char ch)
{
tree id = build_int_cst (char_type_node, (int) ch);
id = m2convert_BuildConvert (location, m2type_GetM2CharType (), id, FALSE);
return m2block_RememberConstant (id);
}
/* BuildCharConstant - creates a character constant given a, string. */
tree
m2type_BuildCharConstant (location_t location, const char *string)
{
return m2type_BuildCharConstantChar (location, string[0]);
}
/* RealToTree - convert a real number into a Tree. */
tree
m2type_RealToTree (char *name)
{
return build_real (
m2type_GetLongRealType (),
REAL_VALUE_ATOF (name, TYPE_MODE (m2type_GetLongRealType ())));
}
/* gm2_start_struct - start to create a struct. */
static tree
gm2_start_struct (location_t location, enum tree_code code, char *name)
{
tree s = make_node (code);
tree id;
m2assert_AssertLocation (location);
if ((name == NULL) || (strcmp (name, "") == 0))
id = NULL_TREE;
else
id = get_identifier (name);
TYPE_PACKED (s) = FALSE; /* This maybe set TRUE later if necessary. */
m2block_pushDecl (build_decl (location, TYPE_DECL, id, s));
return s;
}
/* BuildStartRecord - return a RECORD tree. */
tree
m2type_BuildStartRecord (location_t location, char *name)
{
m2assert_AssertLocation (location);
return gm2_start_struct (location, RECORD_TYPE, name);
}
/* BuildStartUnion - return a union tree. */
tree
m2type_BuildStartUnion (location_t location, char *name)
{
m2assert_AssertLocation (location);
return gm2_start_struct (location, UNION_TYPE, name);
}
/* m2type_BuildStartVarient - builds a varient record. It creates a
record field which has a, name, and whose type is a union. */
tree
m2type_BuildStartVarient (location_t location, char *name)
{
tree varient = m2type_BuildStartUnion (location, name);
tree field = m2type_BuildStartFieldRecord (location, name, varient);
m2assert_AssertLocation (location);
return field;
}
/* m2type_BuildEndVarient - finish the varientField by calling
decl_finish and also finish the type of varientField (which is a
union). */
tree
m2type_BuildEndVarient (location_t location, tree varientField,
tree varientList, int isPacked)
{
tree varient = TREE_TYPE (varientField);
m2assert_AssertLocation (location);
varient = m2type_BuildEndRecord (location, varient, varientList, isPacked);
gm2_finish_decl (location, varientField);
return varientField;
}
/* m2type_BuildStartFieldVarient - builds a field varient record. It
creates a record field which has a, name, and whose type is a
record. */
tree
m2type_BuildStartFieldVarient (location_t location, char *name)
{
tree record = m2type_BuildStartRecord (location, name);
tree field = m2type_BuildStartFieldRecord (location, name, record);
m2assert_AssertLocation (location);
return field;
}
/* BuildEndRecord - a heavily pruned finish_struct from c-decl.cc. It
sets the context for each field to, t, propagates isPacked
throughout the fields in the structure. */
tree
m2type_BuildEndRecord (location_t location, tree record, tree fieldlist,
int isPacked)
{
tree x, d;
m2assert_AssertLocation (location);
/* If this type was previously laid out as a forward reference, make
sure we lay it out again. */
TYPE_SIZE (record) = 0;
/* Install struct as DECL_CONTEXT of each field decl. Also process
specified field sizes, found in the DECL_INITIAL, storing 0 there
after the type has been changed to precision equal to its width,
rather than the precision of the specified standard type. (Correct
layout requires the original type to have been preserved until now). */
for (x = fieldlist; x; x = TREE_CHAIN (x))
{
DECL_CONTEXT (x) = record;
if (TYPE_PACKED (record) && TYPE_ALIGN (TREE_TYPE (x)) > BITS_PER_UNIT)
DECL_PACKED (x) = 1;
if (isPacked)
{
DECL_PACKED (x) = 1;
DECL_BIT_FIELD (x) = 1;
}
}
/* Now we have the nearly final fieldlist. Record it, then lay out
the structure or union (including the fields). */
TYPE_FIELDS (record) = fieldlist;
layout_type (record);
/* Now we have the truly final field list. Store it in this type and
in the variants. */
for (x = TYPE_MAIN_VARIANT (record); x; x = TYPE_NEXT_VARIANT (x))
{
TYPE_FIELDS (x) = TYPE_FIELDS (record);
TYPE_LANG_SPECIFIC (x) = TYPE_LANG_SPECIFIC (record);
SET_TYPE_ALIGN (x, TYPE_ALIGN (record));
TYPE_USER_ALIGN (x) = TYPE_USER_ALIGN (record);
}
d = build_decl (location, TYPE_DECL, NULL, record);
TYPE_STUB_DECL (record) = d;
/* Finish debugging output for this type. This must be done after we have
called build_decl. */
rest_of_type_compilation (record, m2block_toplevel ());
return record;
}
/* m2type_BuildEndFieldVarient - finish the varientField by calling
decl_finish and also finish the type of varientField (which is a
record). */
tree
m2type_BuildEndFieldVarient (location_t location, tree varientField,
tree varientList, int isPacked)
{
tree record = TREE_TYPE (varientField);
m2assert_AssertLocation (location);
record = m2type_BuildEndRecord (location, record, varientList, isPacked);
gm2_finish_decl (location, varientField);
return varientField;
}
/* m2type_BuildStartFieldRecord - starts building a field record. It
returns the field which must be completed by calling
gm2_finish_decl. */
tree
m2type_BuildStartFieldRecord (location_t location, char *name, tree type)
{
tree field, declarator;
m2assert_AssertLocation (location);
if ((name == NULL) || (strcmp (name, "") == 0))
declarator = NULL_TREE;
else
declarator = get_identifier (name);
field = build_decl (location, FIELD_DECL, declarator,
m2tree_skip_type_decl (type));
return field;
}
/* Build a record field with name (name maybe NULL), returning the
new field declaration, FIELD_DECL.
This is done during the parsing of the struct declaration. The
FIELD_DECL nodes are chained together and the lot of them are
ultimately passed to `build_struct' to make the RECORD_TYPE node. */
tree
m2type_BuildFieldRecord (location_t location, char *name, tree type)
{
tree field = m2type_BuildStartFieldRecord (location, name, type);
m2assert_AssertLocation (location);
gm2_finish_decl (location, field);
return field;
}
/* ChainOn - interface so that Modula-2 can also create chains of
declarations. */
tree
m2type_ChainOn (tree t1, tree t2)
{
return chainon (t1, t2);
}
/* ChainOnParamValue - adds a list node {{name, str}, value} into the
tree list. */
tree
m2type_ChainOnParamValue (tree list, tree name, tree str, tree value)
{
return chainon (list, build_tree_list (build_tree_list (name, str), value));
}
/* AddStringToTreeList - adds, string, to list. */
tree
m2type_AddStringToTreeList (tree list, tree string)
{
return tree_cons (NULL_TREE, string, list);
}
/* SetAlignment - sets the alignment of a, node, to, align. It
duplicates the, node, and sets the alignment to prevent alignment
effecting behaviour elsewhere. */
tree
m2type_SetAlignment (tree node, tree align)
{
tree type = NULL_TREE;
tree decl = NULL_TREE;
int is_type = FALSE;
int i;
if (DECL_P (node))
{
decl = node;
is_type = (TREE_CODE (node) == TYPE_DECL);
type = TREE_TYPE (decl);
}
else if (TYPE_P (node))
{
is_type = 1;
type = node;
}
if (TREE_CODE (align) != INTEGER_CST)
error ("requested alignment is not a constant");
else if ((i = tree_log2 (align)) == -1)
error ("requested alignment is not a power of 2");
else if (i > HOST_BITS_PER_INT - 2)
error ("requested alignment is too large");
else if (is_type)
{
/* If we have a TYPE_DECL, then copy the type, so that we don't
accidentally modify a builtin type. See pushdecl. */
if (decl && TREE_TYPE (decl) != error_mark_node
&& DECL_ORIGINAL_TYPE (decl) == NULL_TREE)
{
tree tt = TREE_TYPE (decl);
type = build_variant_type_copy (type);
DECL_ORIGINAL_TYPE (decl) = tt;
TYPE_NAME (type) = decl;
TREE_USED (type) = TREE_USED (decl);
TREE_TYPE (decl) = type;
}
SET_TYPE_ALIGN (type, (1 << i) * BITS_PER_UNIT);
TYPE_USER_ALIGN (type) = 1;
if (decl)
{
SET_DECL_ALIGN (decl, (1 << i) * BITS_PER_UNIT);
DECL_USER_ALIGN (decl) = 1;
}
}
else if (TREE_CODE (decl) != VAR_DECL && TREE_CODE (decl) != FIELD_DECL)
error ("alignment may not be specified for %qD", decl);
else
{
SET_DECL_ALIGN (decl, (1 << i) * BITS_PER_UNIT);
DECL_USER_ALIGN (decl) = 1;
}
return node;
}
/* SetDeclPacked - sets the packed bit in decl TREE, node. It
returns the node. */
tree
m2type_SetDeclPacked (tree node)
{
DECL_PACKED (node) = 1;
return node;
}
/* SetTypePacked - sets the packed bit in type TREE, node. It
returns the node. */
tree
m2type_SetTypePacked (tree node)
{
TYPE_PACKED (node) = 1;
return node;
}
/* SetRecordFieldOffset - returns field after the byteOffset and
bitOffset has been applied to it. */
tree
m2type_SetRecordFieldOffset (tree field, tree byteOffset, tree bitOffset,
tree fieldtype, tree nbits)
{
DECL_FIELD_OFFSET (field) = byteOffset;
DECL_FIELD_BIT_OFFSET (field) = bitOffset;
TREE_TYPE (field) = m2tree_skip_type_decl (fieldtype);
DECL_SIZE (field) = bitsize_int (TREE_INT_CST_LOW (nbits));
return field;
}
/* BuildPackedFieldRecord - builds a packed field record of, name,
and, fieldtype. */
tree
m2type_BuildPackedFieldRecord (location_t location, char *name, tree fieldtype)
{
m2assert_AssertLocation (location);
return m2type_BuildFieldRecord (location, name, fieldtype);
}
/* BuildNumberOfArrayElements - returns the number of elements in an
arrayType. */
tree
m2type_BuildNumberOfArrayElements (location_t location, tree arrayType)
{
tree index = TYPE_DOMAIN (arrayType);
tree high = TYPE_MAX_VALUE (index);
tree low = TYPE_MIN_VALUE (index);
tree elements = m2expr_BuildAdd (
location, m2expr_BuildSub (location, high, low, FALSE),
m2expr_GetIntegerOne (location), FALSE);
m2assert_AssertLocation (location);
return elements;
}
/* AddStatement - maps onto add_stmt. */
void
m2type_AddStatement (location_t location, tree t)
{
if (t != NULL_TREE)
add_stmt (location, t);
}
/* MarkFunctionReferenced - marks a function as referenced. */
void
m2type_MarkFunctionReferenced (tree f)
{
if (f != NULL_TREE)
if (TREE_CODE (f) == FUNCTION_DECL)
mark_decl_referenced (f);
}
/* GarbageCollect - force gcc to garbage collect. */
void
m2type_GarbageCollect (void)
{
ggc_collect ();
}
/* gm2_type_for_size - return an integer type with BITS bits of
precision, that is unsigned if UNSIGNEDP is nonzero, otherwise
signed. */
tree
m2type_gm2_type_for_size (unsigned int bits, int unsignedp)
{
if (bits == TYPE_PRECISION (integer_type_node))
return unsignedp ? unsigned_type_node : integer_type_node;
if (bits == TYPE_PRECISION (signed_char_type_node))
return unsignedp ? unsigned_char_type_node : signed_char_type_node;
if (bits == TYPE_PRECISION (short_integer_type_node))
return unsignedp ? short_unsigned_type_node : short_integer_type_node;
if (bits == TYPE_PRECISION (long_integer_type_node))
return unsignedp ? long_unsigned_type_node : long_integer_type_node;
if (bits == TYPE_PRECISION (long_long_integer_type_node))
return (unsignedp ? long_long_unsigned_type_node
: long_long_integer_type_node);
if (bits <= TYPE_PRECISION (intQI_type_node))
return unsignedp ? unsigned_intQI_type_node : intQI_type_node;
if (bits <= TYPE_PRECISION (intHI_type_node))
return unsignedp ? unsigned_intHI_type_node : intHI_type_node;
if (bits <= TYPE_PRECISION (intSI_type_node))
return unsignedp ? unsigned_intSI_type_node : intSI_type_node;
if (bits <= TYPE_PRECISION (intDI_type_node))
return unsignedp ? unsigned_intDI_type_node : intDI_type_node;
return 0;
}
/* gm2_unsigned_type - return an unsigned type the same as TYPE in
other respects. */
tree
m2type_gm2_unsigned_type (tree type)
{
tree type1 = TYPE_MAIN_VARIANT (type);
if (type1 == signed_char_type_node || type1 == char_type_node)
return unsigned_char_type_node;
if (type1 == integer_type_node)
return unsigned_type_node;
if (type1 == short_integer_type_node)
return short_unsigned_type_node;
if (type1 == long_integer_type_node)
return long_unsigned_type_node;
if (type1 == long_long_integer_type_node)
return long_long_unsigned_type_node;
#if HOST_BITS_PER_WIDE_INT >= 64
if (type1 == intTI_type_node)
return unsigned_intTI_type_node;
#endif
if (type1 == intDI_type_node)
return unsigned_intDI_type_node;
if (type1 == intSI_type_node)
return unsigned_intSI_type_node;
if (type1 == intHI_type_node)
return unsigned_intHI_type_node;
if (type1 == intQI_type_node)
return unsigned_intQI_type_node;
return m2type_gm2_signed_or_unsigned_type (TRUE, type);
}
/* gm2_signed_type - return a signed type the same as TYPE in other
respects. */
tree
m2type_gm2_signed_type (tree type)
{
tree type1 = TYPE_MAIN_VARIANT (type);
if (type1 == unsigned_char_type_node || type1 == char_type_node)
return signed_char_type_node;
if (type1 == unsigned_type_node)
return integer_type_node;
if (type1 == short_unsigned_type_node)
return short_integer_type_node;
if (type1 == long_unsigned_type_node)
return long_integer_type_node;
if (type1 == long_long_unsigned_type_node)
return long_long_integer_type_node;
#if HOST_BITS_PER_WIDE_INT >= 64
if (type1 == unsigned_intTI_type_node)
return intTI_type_node;
#endif
if (type1 == unsigned_intDI_type_node)
return intDI_type_node;
if (type1 == unsigned_intSI_type_node)
return intSI_type_node;
if (type1 == unsigned_intHI_type_node)
return intHI_type_node;
if (type1 == unsigned_intQI_type_node)
return intQI_type_node;
return m2type_gm2_signed_or_unsigned_type (FALSE, type);
}
/* check_type - if the precision of baseType and type are the same
then return true and set the signed or unsigned type in result
else return false. */
static int
check_type (tree baseType, tree type, int unsignedp, tree baseu, tree bases,
tree *result)
{
if (TYPE_PRECISION (baseType) == TYPE_PRECISION (type))
{
if (unsignedp)
*result = baseu;
else
*result = bases;
return TRUE;
}
return FALSE;
}
/* gm2_signed_or_unsigned_type - return a type the same as TYPE
except unsigned or signed according to UNSIGNEDP. */
tree
m2type_gm2_signed_or_unsigned_type (int unsignedp, tree type)
{
tree result;
if (!INTEGRAL_TYPE_P (type) || TYPE_UNSIGNED (type) == unsignedp)
return type;
/* For INTEGER_TYPEs we must check the precision as well, so as to
yield correct results for bit-field types. */
if (check_type (signed_char_type_node, type, unsignedp,
unsigned_char_type_node, signed_char_type_node, &result))
return result;
if (check_type (integer_type_node, type, unsignedp, unsigned_type_node,
integer_type_node, &result))
return result;
if (check_type (short_integer_type_node, type, unsignedp,
short_unsigned_type_node, short_integer_type_node, &result))
return result;
if (check_type (long_integer_type_node, type, unsignedp,
long_unsigned_type_node, long_integer_type_node, &result))
return result;
if (check_type (long_long_integer_type_node, type, unsignedp,
long_long_unsigned_type_node, long_long_integer_type_node,
&result))
return result;
#if HOST_BITS_PER_WIDE_INT >= 64
if (check_type (intTI_type_node, type, unsignedp, unsigned_intTI_type_node,
intTI_type_node, &result))
return result;
#endif
if (check_type (intDI_type_node, type, unsignedp, unsigned_intDI_type_node,
intDI_type_node, &result))
return result;
if (check_type (intSI_type_node, type, unsignedp, unsigned_intSI_type_node,
intSI_type_node, &result))
return result;
if (check_type (intHI_type_node, type, unsignedp, unsigned_intHI_type_node,
intHI_type_node, &result))
return result;
if (check_type (intQI_type_node, type, unsignedp, unsigned_intQI_type_node,
intQI_type_node, &result))
return result;
#undef TYPE_OK
return type;
}
/* IsAddress - returns TRUE if the type is an ADDRESS. */
int
m2type_IsAddress (tree type)
{
return type == ptr_type_node;
}
#include "gt-m2-m2type.h"
-----------------------------
New file: gcc/m2/gm2-gcc/m2top.h
-----------------------------
/* m2top.h header file for m2top.cc.
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/>. */
#if !defined(m2top_h)
#define m2top_h
#if defined(m2top_c)
#if defined(__GNUG__)
#define EXTERN extern "C"
#else /* !__GNUG__. */
#define EXTERN
#endif /* !__GNUG__. */
#else
#if defined(__GNUG__)
#define EXTERN extern "C"
#else /* !__GNUG__. */
#define EXTERN extern
#endif /* !__GNUG__. */
#endif /* !m2top_c. */
EXTERN void m2top_StartGlobalContext (void);
EXTERN void m2top_EndGlobalContext (void);
EXTERN void m2top_SetFlagUnitAtATime (int b);
#undef EXTERN
#endif /* m2top_h. */
-----------------------------
New file: gcc/m2/plugin/m2rte.cc
-----------------------------
/* m2rte.cc a plugin to detect runtime exceptions at compiletime.
Copyright (C) 2017-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-plugin.h"
#include "config.h"
#include "system.h"
#include "coretypes.h"
#include "options.h"
#include "tree-pass.h"
#include "diagnostic-core.h"
#include "flags.h"
#include "intl.h"
#include "plugin.h"
#include "tree.h"
#include "gimple.h"
#include "gimplify.h"
#include "gimple-iterator.h"
#include "gimplify-me.h"
#include "gimple-pretty-print.h"
#include "plugin-version.h"
#include "diagnostic.h"
#include "context.h"
#include "rtegraph.h"
extern bool ggc_force_collect;
extern void ggc_collect (void);
#undef DEBUG_BASICBLOCK
int plugin_is_GPL_compatible;
void debug_tree (tree);
/* All dialects of Modula-2 issue some or all of these runtime error calls.
This plugin detects whether a runtime error will be called in the first
basic block of a reachable function. */
static const char *m2_runtime_error_calls[] = {
"M2RTS_AssignmentException",
"M2RTS_ReturnException",
"M2RTS_IncException",
"M2RTS_DecException",
"M2RTS_InclException",
"M2RTS_ExclException",
"M2RTS_ShiftException",
"M2RTS_RotateException",
"M2RTS_StaticArraySubscriptException",
"M2RTS_DynamicArraySubscriptException",
"M2RTS_ForLoopBeginException",
"M2RTS_ForLoopToException",
"M2RTS_ForLoopEndException",
"M2RTS_PointerNilException",
"M2RTS_NoReturnException",
"M2RTS_CaseException",
"M2RTS_WholeNonPosDivException",
"M2RTS_WholeNonPosModException",
"M2RTS_WholeZeroDivException",
"M2RTS_WholeZeroRemException",
"M2RTS_WholeValueException",
"M2RTS_RealValueException",
"M2RTS_ParameterException",
"M2RTS_NoException",
NULL,
};
#if defined(DEBUG_BASICBLOCK)
/* pretty_function display the name of the function. */
static void
pretty_function (tree fndecl)
{
if (fndecl != NULL && (DECL_NAME (fndecl) != NULL))
{
const char *n = IDENTIFIER_POINTER (DECL_NAME (fndecl));
fprintf (stderr, "PROCEDURE %s ;\n", n);
}
}
#endif
void
print_rtl (FILE *outf, const_rtx rtx_first);
/* strend returns true if string name has ending. */
static bool
strend (const char *name, const char *ending)
{
unsigned int len = strlen (name);
return (len > strlen (ending)
&& (strcmp (&name[len-strlen (ending)], ending) == 0));
}
/* is_constructor returns true if the function name is that of a module
constructor or deconstructor. */
static bool
is_constructor (tree fndecl)
{
const char *name = IDENTIFIER_POINTER (DECL_NAME (fndecl));
unsigned int len = strlen (name);
return ((len > strlen ("_M2_"))
&& (strncmp (name, "_M2_", strlen ("_M2_")) == 0)
&& (strend (name, "_init") || strend (name, "_finish")));
}
/* is_external returns true if the function is extern. */
static bool
is_external (tree function)
{
return (! DECL_EXTERNAL (function))
&& TREE_PUBLIC (function)
&& TREE_STATIC (function);
}
/* is_external returns true if the function is a call to a Modula-2
runtime exception handler. */
static bool
is_rte (tree fndecl)
{
const char *n = IDENTIFIER_POINTER (DECL_NAME (fndecl));
for (int i = 0; m2_runtime_error_calls[i] != NULL; i++)
if (strcmp (m2_runtime_error_calls[i], n) == 0)
return true;
return false;
}
/* examine_call extract the function tree from the gimple call
statement and check whether it is a call to a runtime exception. */
static void
examine_call (gimple *stmt)
{
tree fndecl = gimple_call_fndecl (stmt);
rtenode *func = rtegraph_lookup (stmt, fndecl, true);
// rtegraph_dump ();
if (fndecl != NULL && (DECL_NAME (fndecl) != NULL))
{
/* Firstly check if the function is a runtime exception. */
if (is_rte (fndecl))
{
/* Remember runtime exception call. */
rtegraph_include_rtscall (func);
/* Add the callee to the list of candidates to be queried reachable. */
rtegraph_candidates_include (func);
return;
}
}
/* Add it to the list of calls. */
rtegraph_include_function_call (func);
}
/* examine_function_decl, check if the current function is a module
constructor/deconstructor. Also check if the current function is
declared as external. */
static void
examine_function_decl (rtenode *rt)
{
tree fndecl = rtegraph_get_func (rt);
if (fndecl != NULL && (DECL_NAME (fndecl) != NULL))
{
/* Check if the function is a module constructor. */
if (is_constructor (fndecl))
rtegraph_constructors_include (rt);
/* Can it be called externally? */
if (is_external (fndecl))
rtegraph_externs_include (rt);
}
}
/* Check and warn if STMT is a self-assign statement. */
static void
runtime_exception_inevitable (gimple *stmt)
{
if (is_gimple_call (stmt))
examine_call (stmt);
}
namespace {
const pass_data pass_data_exception_detection =
{
GIMPLE_PASS, /* type */
"runtime_exception_inevitable", /* name */
OPTGROUP_NONE, /* optinfo_flags */
TV_NONE, /* tv_id */
PROP_gimple_lcf , /* properties_required */
0, /* properties_provided */
0, /* properties_destroyed */
0, /* todo_flags_start */
0, /* todo_flags_finish */
};
class pass_warn_exception_inevitable : public gimple_opt_pass
{
public:
pass_warn_exception_inevitable(gcc::context *ctxt)
: gimple_opt_pass(pass_data_exception_detection, ctxt)
{}
virtual unsigned int execute (function *);
};
/* execute checks the first basic block of function fun to see if it
calls a runtime exception. */
unsigned int
pass_warn_exception_inevitable::execute (function *fun)
{
gimple_stmt_iterator gsi;
basic_block bb;
/* Record a function declaration. */
rtenode *fn = rtegraph_lookup (fun->gimple_body, fun->decl, false);
rtegraph_set_current_function (fn);
/* Check if the current function is a module constructor/deconstructor.
Also check if the current function is declared as external. */
examine_function_decl (fn);
#if defined(DEBUG_BASICBLOCK)
pretty_function (fun->decl);
int basic_count = 0;
#endif
FOR_EACH_BB_FN (bb, fun)
{
#if defined(DEBUG_BASICBLOCK)
int stmt_count = 0;
#endif
for (gsi = gsi_start_bb (bb); !gsi_end_p (gsi); gsi_next (&gsi))
{
#if defined(DEBUG_BASICBLOCK)
printf (" [%d][%d] [basic block][statement]\n",
basic_count, stmt_count);
stmt_count++;
#endif
runtime_exception_inevitable (gsi_stmt (gsi));
#if defined(DEBUG_BASICBLOCK)
debug (gsi_stmt (gsi));
#endif
}
/* We only care about the first basic block in each function.
We could continue to search if this edge falls though (top
of a loop for example) but for now this is cautiously safe.
--fixme-- */
return 0;
#if defined(DEBUG_BASICBLOCK)
basic_count++;
#endif
}
return 0;
}
/* analyse_graph discovers any reachable call to a runtime exception in the
first basic block of a reachable function. It then calls rtegraph_finish
to tidy up and return all dynamic memory used. */
void analyse_graph (void *gcc_data, void *user_data)
{
rtegraph_discover ();
rtegraph_finish ();
}
} // anon namespace
static gimple_opt_pass *
make_pass_warn_exception_inevitable (gcc::context *ctxt)
{
return new pass_warn_exception_inevitable (ctxt);
}
/* plugin_init, check the version and register the plugin. */
int
plugin_init (struct plugin_name_args *plugin_info,
struct plugin_gcc_version *version)
{
struct register_pass_info pass_info;
const char *plugin_name = plugin_info->base_name;
if (!plugin_default_version_check (version, &gcc_version))
{
fprintf (stderr, "incorrect GCC version (%s) this plugin was built for GCC version %s\n",
version->basever, gcc_version.basever);
return 1;
}
/* Runtime exception inevitable detection. This plugin is most effective if
it is run after all optimizations. This is plugged in at the end of
gimple range of optimizations. */
pass_info.pass = make_pass_warn_exception_inevitable (g);
pass_info.reference_pass_name = "*warn_function_noreturn";
pass_info.ref_pass_instance_number = 1;
pass_info.pos_op = PASS_POS_INSERT_AFTER;
rtegraph_init ();
register_callback (plugin_name,
PLUGIN_PASS_MANAGER_SETUP,
NULL,
&pass_info);
register_callback (plugin_name,
PLUGIN_FINISH, analyse_graph, NULL);
return 0;
}
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2022-05-19 13:55 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2022-05-19 13:55 [PATCH] Modula-2: merge proposal/review: 5/9 05.patch-set-04-2 v2 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).