* [PATCH] Modula-2: merge proposal/review: 4/9 04.patch-set-04-1
@ 2022-05-18 13:45 Gaius Mulley
0 siblings, 0 replies; only message in thread
From: Gaius Mulley @ 2022-05-18 13:45 UTC (permalink / raw)
To: gcc-patches
Hello,
this email contains:
4. the glue code (between Modula-2 and GCC) part 1/3.
(*.{cc,h} files).
------------------------
New file: gcc/m2/gm2-gcc/README
------------------------
This directory contains the interface code between the Modula-2 front
end and GCC. In effect this is the Modula-2 compiler GCC Tree API.
It is an internal API only. Many of these filenames match their GCC C
family counterparts. So for example m2decl.def and m2decl.cc are the
Modula-2 front end version of c-decl.cc.
------------------------
New file: gcc/m2/gm2-gcc/dynamicstrings.h
------------------------
/* dynamicstrings.h provides a minimal interface to a string library.
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(dynamicstrings_h)
#define dynamicstrings_h
#if defined(dynamicstrings_c)
#define EXTERN
#else /* !dynamicstrings_c. */
#define EXTERN extern
#endif /* !dynamicstrings_c. */
typedef void *dynamicstrings_string;
EXTERN dynamicstrings_string DynamicStrings_Mark (dynamicstrings_string s);
EXTERN dynamicstrings_string
DynamicStrings_InitStringCharStar (dynamicstrings_string s);
#undef EXTERN
#endif /* !dynamicstrings_h. */
------------------------
New file: gcc/m2/gm2-gcc/init.h
------------------------
/* init.h header file for init.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(init_h)
#define init_h
#if defined(init_cpp)
extern "C" {
void init_FrontEndInit (void);
void init_PerCompilationInit (const char *filename);
}
#else /* !init_cpp. */
void init_FrontEndInit (void);
void init_PerCompilationInit (const char *filename);
#endif /* !init_cpp. */
#endif /*! init_h. */
------------------------
New file: gcc/m2/gm2-gcc/init.cc
------------------------
/* init.cc initializes the modules of the GNU Modula-2 front end.
Copyright (C) 2012-2022 Free Software Foundation, Inc.
Contributed by Gaius Mulley <gaius@glam.ac.uk>.
This file is part of GNU Modula-2.
GNU Modula-2 is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 3, or (at your option)
any later version.
GNU Modula-2 is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
General Public License for more details.
You should have received a copy of the GNU General Public License
along with GNU Modula-2; see the file COPYING3. If not see
<http://www.gnu.org/licenses/>. */
#include "init.h"
#include "config.h"
#include "system.h"
#if defined(__GNUG__)
#define EXTERN extern "C"
#else /* !__GNUG__ */
#define EXTERN extern
#endif /* !__GNUG__ */
EXTERN void _M2_M2Bitset_init (int argc, char *argv[]);
EXTERN void _M2_Debug_init (int argc, char *argv[]);
EXTERN void _M2_M2Defaults_init (int argc, char *argv[]);
EXTERN void _M2_Environment_init (int argc, char *argv[]);
EXTERN void _M2_RTExceptions_init (int argc, char *argv[]);
EXTERN void _M2_M2EXCEPTION_init (int argc, char *argv[]);
EXTERN void _M2_M2RTS_init (int argc, char *argv[]);
EXTERN void _M2_SysExceptions_init (int argc, char *argv[]);
EXTERN void _M2_DynamicStrings_init (int argc, char *argv[]);
EXTERN void _M2_Assertion_init (int argc, char *argv[]);
EXTERN void _M2_FormatStrings_init (int argc, char *argv[]);
EXTERN void _M2_FIO_init (int argc, char *argv[]);
EXTERN void _M2_SFIO_init (int argc, char *argv[]);
EXTERN void _M2_SArgs_init (int argc, char *argv[]);
EXTERN void _M2_Lists_init (int argc, char *argv[]);
EXTERN void _M2_UnixArgs_init (int argc, char *argv[]);
EXTERN void _M2_Args_init (int argc, char *argv[]);
EXTERN void _M2_wrapc_init (int argc, char *argv[]);
EXTERN void _M2_TimeString_init (int argc, char *argv[]);
EXTERN void _M2_IO_init (int argc, char *argv[]);
EXTERN void _M2_StdIO_init (int argc, char *argv[]);
EXTERN void _M2_CmdArgs_init (int argc, char *argv[]);
EXTERN void _M2_M2Preprocess_init (int argc, char *argv[]);
EXTERN void _M2_M2Error_init (int argc, char *argv[]);
EXTERN void _M2_M2Search_init (int argc, char *argv[]);
EXTERN void _M2_Indexing_init (int argc, char *argv[]);
EXTERN void _M2_NameKey_init (int argc, char *argv[]);
EXTERN void _M2_NumberIO_init (int argc, char *argv[]);
EXTERN void _M2_FpuIO_init (int argc, char *argv[]);
EXTERN void _M2_SysStorage_init (int argc, char *argv[]);
EXTERN void _M2_Storage_init (int argc, char *argv[]);
EXTERN void _M2_StrIO_init (int argc, char *argv[]);
EXTERN void _M2_M2Debug_init (int argc, char *argv[]);
EXTERN void _M2_M2Batch_init (int argc, char *argv[]);
EXTERN void _M2_StrLib_init (int argc, char *argv[]);
EXTERN void _M2_M2ALU_init (int argc, char *argv[]);
EXTERN void _M2_M2Options_init (int argc, char *argv[]);
EXTERN void _M2_M2Comp_init (int argc, char *argv[]);
EXTERN void _M2_M2LexBuf_init (int argc, char *argv[]);
EXTERN void _M2_SymbolTable_init (int argc, char *argv[]);
EXTERN void _M2_M2Base_init (int argc, char *argv[]);
EXTERN void _M2_M2Quads_init (int argc, char *argv[]);
EXTERN void _M2_SymbolKey_init (int argc, char *argv[]);
EXTERN void _M2_FifoQueue_init (int argc, char *argv[]);
EXTERN void _M2_M2Reserved_init (int argc, char *argv[]);
EXTERN void _M2_M2Const_init (int argc, char *argv[]);
EXTERN void _M2_P1SymBuild_init (int argc, char *argv[]);
EXTERN void _M2_P2SymBuild_init (int argc, char *argv[]);
EXTERN void _M2_P3SymBuild_init (int argc, char *argv[]);
EXTERN void _M2_M2System_init (int argc, char *argv[]);
EXTERN void _M2_M2BasicBlock_init (int argc, char *argv[]);
EXTERN void _M2_M2Pass_init (int argc, char *argv[]);
EXTERN void _M2_M2Code_init (int argc, char *argv[]);
EXTERN void _M2_M2AsmUtil_init (int argc, char *argv[]);
EXTERN void _M2_M2FileName_init (int argc, char *argv[]);
EXTERN void _M2_M2Version_init (int argc, char *argv[]);
EXTERN void _M2_M2Students_init (int argc, char *argv[]);
EXTERN void _M2_StrCase_init (int argc, char *argv[]);
EXTERN void _M2_SymbolConversion_init (int argc, char *argv[]);
EXTERN void _M2_M2GCCDeclare_init (int argc, char *argv[]);
EXTERN void _M2_M2GenGCC_init (int argc, char *argv[]);
EXTERN void _M2_M2Range_init (int argc, char *argv[]);
EXTERN void _M2_M2Swig_init (int argc, char *argv[]);
EXTERN void _M2_M2MetaError_init (int argc, char *argv[]);
EXTERN void _M2_M2CaseList_init (int argc, char *argv[]);
EXTERN void _M2_PCSymBuild_init (int argc, char *argv[]);
EXTERN void _M2_PCBuild_init (int argc, char *argv[]);
EXTERN void _M2_Sets_init (int argc, char *argv[]);
EXTERN void _M2_dtoa_init (int argc, char *argv[]);
EXTERN void _M2_ldtoa_init (int argc, char *argv[]);
EXTERN void _M2_M2Check_init (int argc, char *argv[]);
EXTERN void _M2_M2SSA_init (int argc, char *argv[]);
EXTERN void exit (int);
EXTERN void M2Comp_compile (const char *filename);
EXTERN void RTExceptions_DefaultErrorCatch (void);
/* FrontEndInit - initialise the modules, this is a global
initialisation. This is called once. */
void
init_FrontEndInit (void)
{
_M2_Debug_init (0, NULL);
_M2_RTExceptions_init (0, NULL);
_M2_M2Defaults_init (0, NULL);
_M2_Environment_init (0, NULL);
_M2_M2EXCEPTION_init (0, NULL);
_M2_M2RTS_init (0, NULL);
_M2_SysExceptions_init (0, NULL);
_M2_DynamicStrings_init (0, NULL);
_M2_Assertion_init (0, NULL);
_M2_FormatStrings_init (0, NULL);
_M2_FIO_init (0, NULL);
_M2_SFIO_init (0, NULL);
_M2_SArgs_init (0, NULL);
_M2_Lists_init (0, NULL);
_M2_UnixArgs_init (0, NULL);
_M2_Args_init (0, NULL);
_M2_wrapc_init (0, NULL);
_M2_TimeString_init (0, NULL);
_M2_IO_init (0, NULL);
_M2_StdIO_init (0, NULL);
_M2_CmdArgs_init (0, NULL);
_M2_FpuIO_init (0, NULL);
_M2_SysStorage_init (0, NULL);
_M2_Storage_init (0, NULL);
_M2_StrIO_init (0, NULL);
_M2_StrLib_init (0, NULL);
_M2_dtoa_init (0, NULL);
_M2_ldtoa_init (0, NULL);
_M2_M2Search_init (0, NULL);
_M2_M2Options_init (0, NULL);
}
/* PerCompilationInit - initialise the modules before compiling,
filename. This is to be called every time we compile a new file. */
void
init_PerCompilationInit (const char *filename)
{
_M2_M2Bitset_init (0, NULL);
_M2_M2Preprocess_init (0, NULL);
_M2_M2Error_init (0, NULL);
_M2_Indexing_init (0, NULL);
_M2_NameKey_init (0, NULL);
_M2_NumberIO_init (0, NULL);
_M2_M2Debug_init (0, NULL);
_M2_M2Batch_init (0, NULL);
_M2_M2ALU_init (0, NULL);
_M2_M2Comp_init (0, NULL);
_M2_M2LexBuf_init (0, NULL);
_M2_SymbolTable_init (0, NULL);
_M2_M2Base_init (0, NULL);
_M2_M2Quads_init (0, NULL);
_M2_SymbolKey_init (0, NULL);
_M2_FifoQueue_init (0, NULL);
_M2_M2Reserved_init (0, NULL);
_M2_M2Const_init (0, NULL);
_M2_P1SymBuild_init (0, NULL);
_M2_P2SymBuild_init (0, NULL);
_M2_P3SymBuild_init (0, NULL);
_M2_M2System_init (0, NULL);
_M2_M2BasicBlock_init (0, NULL);
_M2_M2Pass_init (0, NULL);
_M2_M2Code_init (0, NULL);
_M2_M2AsmUtil_init (0, NULL);
_M2_M2FileName_init (0, NULL);
_M2_M2Version_init (0, NULL);
_M2_M2Students_init (0, NULL);
_M2_StrCase_init (0, NULL);
_M2_SymbolConversion_init (0, NULL);
_M2_M2GCCDeclare_init (0, NULL);
_M2_M2GenGCC_init (0, NULL);
_M2_M2Range_init (0, NULL);
_M2_M2Swig_init (0, NULL);
_M2_M2MetaError_init (0, NULL);
_M2_M2CaseList_init (0, NULL);
_M2_PCSymBuild_init (0, NULL);
_M2_PCBuild_init (0, NULL);
_M2_Sets_init (0, NULL);
_M2_M2SSA_init (0, NULL);
_M2_M2Check_init (0, NULL);
M2Comp_compile (filename);
}
------------------------
New file: gcc/m2/gm2-gcc/m2assert.cc
------------------------
/* m2assert.cc provides a simple assertion for location.
Copyright (C) 2012-2022 Free Software Foundation, Inc.
Contributed by Gaius Mulley <gaius@glam.ac.uk>.
This file is part of GNU Modula-2.
GNU Modula-2 is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 3, or (at your option)
any later version.
GNU Modula-2 is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
General Public License for more details.
You should have received a copy of the GNU General Public License
along with GNU Modula-2; see the file COPYING3. If not see
<http://www.gnu.org/licenses/>. */
#include "gcc-consolidation.h"
#include "../gm2-lang.h"
#include "../m2-tree.h"
#define m2assert_c
#include "m2assert.h"
#include "m2options.h"
void
m2assert_AssertLocation (location_t location)
{
/* internally the compiler will use unknown location and
builtins_location so we ignore these values. */
if (location == BUILTINS_LOCATION || location == UNKNOWN_LOCATION)
return;
if (M2Options_OverrideLocation (location) != location)
internal_error ("the location value is corrupt");
}
------------------------
New file: gcc/m2/gm2-gcc/m2linemap.h
------------------------
/* m2linemap.h header file for m2linemap.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(m2linemap_h)
#include "input.h"
#define m2linemap_h
#if defined(m2linemap_c)
#if (__cplusplus)
#define EXTERN extern "C"
#else /* !__cplusplus. */
#define EXTERN
#endif /*!__cplusplus. */
#else /* !m2linemap_c. */
#if (__cplusplus)
#define EXTERN extern "C"
#else /* !__cplusplus. */
#define EXTERN extern
#endif /* !__cplusplus. */
#endif /* !m2linemap_c. */
EXTERN void m2linemap_StartFile (void *filename, unsigned int linebegin);
EXTERN void m2linemap_EndFile (void);
EXTERN void m2linemap_StartLine (unsigned int linenumber,
unsigned int linesize);
EXTERN location_t m2linemap_GetLocationColumn (unsigned int column);
EXTERN location_t m2linemap_GetLocationRange (unsigned int start, unsigned int end);
EXTERN location_t m2linemap_GetLocationBinary (location_t caret,
location_t start, location_t finish);
EXTERN location_t m2linemap_UnknownLocation (void);
EXTERN location_t m2linemap_BuiltinsLocation (void);
EXTERN location_t m2linemap_GetLocationColumn (unsigned int column);
EXTERN int m2linemap_GetLineNoFromLocation (location_t location);
EXTERN int m2linemap_GetColumnNoFromLocation (location_t location);
EXTERN const char *m2linemap_GetFilenameFromLocation (location_t location);
EXTERN void m2linemap_ErrorAt (location_t location, char *message);
EXTERN void m2linemap_ErrorAtf (location_t location, const char *message, ...);
EXTERN void m2linemap_WarningAtf (location_t location, const char *message, ...);
EXTERN void m2linemap_NoteAtf (location_t location, const char *message, ...);
EXTERN void m2linemap_internal_error (const char *message);
EXTERN location_t UnknownLocation (void);
EXTERN location_t BuiltinsLocation (void);
EXTERN void ErrorAt (location_t location, char *message);
EXTERN void ErrorAtf (location_t location, const char *message, ...);
EXTERN void WarningAtf (location_t location, const char *message, ...);
EXTERN void NoteAtf (location_t location, const char *message, ...);
#undef EXTERN
#endif /* m2linemap_h. */
------------------------
New file: gcc/m2/gm2-gcc/m2convert.h
------------------------
/* m2convert.h header file for m2convert.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(m2convert_h)
#define m2convert_h
#if defined(m2convert_c)
#if defined(__GNUG__)
#define EXTERN extern "C"
#else /* !__GNUG__. */
#define EXTERN
#endif /* !__GNUG__. */
#else /* m2convert_c. */
#if defined(__GNUG__)
#define EXTERN extern "C"
#else /* !__GNUG__. */
#define EXTERN extern
#endif /* !__GNUG__. */
#endif /* m2convert_c. */
EXTERN tree m2convert_BuildConvert (location_t location, tree type, tree value,
int checkOverflow);
EXTERN tree m2convert_ConvertToPtr (location_t location_t, tree p);
EXTERN tree m2convert_ConvertString (tree type, tree expr);
EXTERN tree m2convert_ConvertConstantAndCheck (location_t location, tree type,
tree expr);
EXTERN tree m2convert_convertToPtr (location_t location, tree type);
EXTERN tree m2convert_ToCardinal (location_t location, tree expr);
EXTERN tree m2convert_ToInteger (location_t location, tree expr);
EXTERN tree m2convert_ToWord (location_t location, tree expr);
EXTERN tree m2convert_ToBitset (location_t location, tree expr);
EXTERN tree m2convert_ToLoc (location_t location, tree expr);
EXTERN tree m2convert_GenericToType (location_t location, tree type,
tree expr);
#undef EXTERN
#endif /* m2convert_h. */
------------------------
New file: gcc/m2/gm2-gcc/m2linemap.cc
------------------------
/* m2linemap.cc provides an interface to GCC linemaps.
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"
/* utilize some of the C build routines */
#include "../gm2-lang.h"
#include "../m2-tree.h"
#include "m2assert.h"
#include "m2block.h"
#include "m2decl.h"
#include "m2expr.h"
#include "m2options.h"
#include "m2tree.h"
#include "m2type.h"
#define m2linemap_c
#include "m2linemap.h"
static int inFile = FALSE;
#if defined(__cplusplus)
#define EXTERN extern "C"
#else
#define EXTERN
#endif
/* Start getting locations from a new file. */
EXTERN
void
m2linemap_StartFile (void *filename, unsigned int linebegin)
{
if (inFile)
m2linemap_EndFile ();
linemap_add (line_table, LC_ENTER, false,
xstrdup (reinterpret_cast<char *> (filename)), linebegin);
inFile = TRUE;
}
/* Tell the line table the file has ended. */
EXTERN
void
m2linemap_EndFile (void)
{
linemap_add (line_table, LC_LEAVE, 0, NULL, 0);
inFile = FALSE;
}
/* Indicate that there is a new source file line number with a
maximum width. */
EXTERN
void
m2linemap_StartLine (unsigned int linenumber, unsigned int linesize)
{
linemap_line_start (line_table, linenumber, linesize);
}
/* GetLocationColumn, returns a location_t based on the current line
number and column. */
EXTERN
location_t
m2linemap_GetLocationColumn (unsigned int column)
{
return linemap_position_for_column (line_table, column);
}
/* GetLocationRange, returns a location based on the start column
and end column. */
EXTERN
location_t
m2linemap_GetLocationRange (unsigned int start, unsigned int end)
{
location_t caret = m2linemap_GetLocationColumn (start);
source_range where;
where.m_start = linemap_position_for_column (line_table, start);
where.m_finish = linemap_position_for_column (line_table, end);
return make_location (caret, where);
}
static
int
isSrcLocation (location_t location)
{
return (location != BUILTINS_LOCATION) && (location != UNKNOWN_LOCATION);
}
/* GetLocationBinary, returns a location based on the expression
start caret finish locations. */
EXTERN
location_t
m2linemap_GetLocationBinary (location_t caret, location_t start, location_t finish)
{
#if 1
if (isSrcLocation (start) && isSrcLocation (finish) && isSrcLocation (caret)
&& (m2linemap_GetFilenameFromLocation (start) != NULL))
{
linemap_add (line_table, LC_ENTER, false, xstrdup (m2linemap_GetFilenameFromLocation (start)), 1);
gcc_assert (inFile);
location_t location = make_location (caret, start, finish);
/* error_at (location, "testing here"); */
return location;
}
#endif
return caret;
}
/* GetLineNoFromLocation - returns the lineno given a location. */
EXTERN
int
m2linemap_GetLineNoFromLocation (location_t location)
{
if (isSrcLocation (location) && (!M2Options_GetCpp ()))
{
expanded_location xl = expand_location (location);
return xl.line;
}
return 0;
}
/* GetColumnNoFromLocation - returns the columnno given a location. */
EXTERN
int
m2linemap_GetColumnNoFromLocation (location_t location)
{
if (isSrcLocation (location) && (!M2Options_GetCpp ()))
{
expanded_location xl = expand_location (location);
return xl.column;
}
return 0;
}
/* GetFilenameFromLocation - returns the filename given a location. */
EXTERN
const char *
m2linemap_GetFilenameFromLocation (location_t location)
{
if (isSrcLocation (location) && (!M2Options_GetCpp ()))
{
expanded_location xl = expand_location (location);
return xl.file;
}
return NULL;
}
/* ErrorAt - issue an error message. */
EXTERN
void
m2linemap_ErrorAt (location_t location, char *message)
{
error_at (location, message);
}
/* m2linemap_ErrorAtf - wraps up an error message. */
void
m2linemap_ErrorAtf (location_t location, 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, DK_ERROR);
diagnostic_report_diagnostic (global_dc, &diagnostic);
va_end (ap);
}
/* m2linemap_WarningAtf - wraps up a warning message. */
void
m2linemap_WarningAtf (location_t location, 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, DK_WARNING);
diagnostic_report_diagnostic (global_dc, &diagnostic);
va_end (ap);
}
/* m2linemap_NoteAtf - wraps up a note message. */
void
m2linemap_NoteAtf (location_t location, 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, DK_NOTE);
diagnostic_report_diagnostic (global_dc, &diagnostic);
va_end (ap);
}
/* m2linemap_internal_error - allow Modula-2 to use the GCC internal error. */
void
m2linemap_internal_error (const char *message)
{
internal_error (message);
}
/* UnknownLocation - return the predefined location representing an
unknown location. */
EXTERN
location_t
m2linemap_UnknownLocation (void)
{
return UNKNOWN_LOCATION;
}
/* BuiltinsLocation - return the predefined location representing a
builtin. */
EXTERN
location_t
m2linemap_BuiltinsLocation (void)
{
return BUILTINS_LOCATION;
}
------------------------
New file: gcc/m2/gm2-gcc/m2block.cc
------------------------
/* m2block.cc provides an interface to maintaining block structures.
Copyright (C) 2012-2022 Free Software Foundation, Inc.
Contributed by Gaius Mulley <gaius@glam.ac.uk>.
This file is part of GNU Modula-2.
GNU Modula-2 is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 3, or (at your option)
any later version.
GNU Modula-2 is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
General Public License for more details.
You should have received a copy of the GNU General Public License
along with GNU Modula-2; see the file COPYING3. If not see
<http://www.gnu.org/licenses/>. */
#include "gcc-consolidation.h"
#define m2block_c
#include "m2assert.h"
#include "m2block.h"
#include "m2decl.h"
#include "m2options.h"
#include "m2tree.h"
#include "m2treelib.h"
/* For each binding contour we allocate a binding_level structure
which records the entities defined or declared in that contour.
Contours include:
the global one one for each subprogram definition
Binding contours are used to create GCC tree BLOCK nodes. */
struct GTY (()) binding_level
{
/* The function associated with the scope. This is NULL_TREE for the
global scope. */
tree fndecl;
/* A chain of _DECL nodes for all variables, constants, functions,
and typedef types. These are in the reverse of the order supplied. */
tree names;
/* A boolean to indicate whether this is binding level is a global ie
outer module scope. In which case fndecl will be NULL_TREE. */
int is_global;
/* The context of the binding level, for a function binding level
this will be the same as fndecl, however for a global binding level
this is a translation_unit. */
tree context;
/* The binding level below this one. This field is only used when
the binding level has been pushed by pushFunctionScope. */
struct binding_level *next;
/* All binding levels are placed onto this list. */
struct binding_level *list;
/* A varray of trees, which represent the list of statement
sequences. */
vec<tree, va_gc> *m2_statements;
/* A list of constants (only kept in the global binding level).
Constants need to be kept through the life of the compilation, as the
same constants can be used in any scope. */
tree constants;
/* A list of inner module initialisation functions. */
tree init_functions;
/* A list of types created by M2GCCDeclare prior to code generation
and those which may not be specifically declared and saved via a
push_decl. */
tree types;
/* A list of all DECL_EXPR created within this binding level. This
will be prepended to the statement list once the binding level (scope
is finished). */
tree decl;
/* A list of labels which have been created in this scope. */
tree labels;
/* The number of times this level has been pushed. */
int count;
};
/* The binding level currently in effect. */
static GTY (()) struct binding_level *current_binding_level;
/* The outermost binding level, for names of file scope. This is
created when the compiler is started and exists through the entire
run. */
static GTY (()) struct binding_level *global_binding_level;
/* The head of the binding level lists. */
static GTY (()) struct binding_level *head_binding_level;
/* The current statement tree. */
typedef struct stmt_tree_s *stmt_tree_t;
#undef DEBUGGING
static location_t pending_location;
static int pending_statement = FALSE;
/* assert_global_names - asserts that the global_binding_level->names
can be chained. */
static void
assert_global_names (void)
{
tree p = global_binding_level->names;
while (p)
p = TREE_CHAIN (p);
}
/* lookupLabel - return label tree in current scope, otherwise
NULL_TREE. */
static tree
lookupLabel (tree id)
{
tree t;
for (t = current_binding_level->labels; t != NULL_TREE; t = TREE_CHAIN (t))
{
tree l = TREE_VALUE (t);
if (id == DECL_NAME (l))
return l;
}
return NULL_TREE;
}
/* getLabel - return the label, name, or create a label, name in the
current scope. */
tree
m2block_getLabel (location_t location, char *name)
{
tree id = get_identifier (name);
tree label = lookupLabel (id);
if (label == NULL_TREE)
{
label = build_decl (location, LABEL_DECL, id, void_type_node);
current_binding_level->labels
= tree_cons (NULL_TREE, label, current_binding_level->labels);
}
if (DECL_CONTEXT (label) == NULL_TREE)
DECL_CONTEXT (label) = current_function_decl;
ASSERT ((DECL_CONTEXT (label) == current_function_decl),
current_function_decl);
DECL_MODE (label) = VOIDmode;
return label;
}
static void
init_binding_level (struct binding_level *l)
{
l->fndecl = NULL;
l->names = NULL;
l->is_global = 0;
l->context = NULL;
l->next = NULL;
l->list = NULL;
vec_alloc (l->m2_statements, 1);
l->constants = NULL;
l->init_functions = NULL;
l->types = NULL;
l->decl = NULL;
l->labels = NULL;
l->count = 0;
}
static struct binding_level *
newLevel (void)
{
struct binding_level *newlevel = ggc_alloc<binding_level> ();
init_binding_level (newlevel);
/* now we a push_statement_list. */
vec_safe_push (newlevel->m2_statements, m2block_begin_statement_list ());
return newlevel;
}
tree *
m2block_cur_stmt_list_addr (void)
{
ASSERT_CONDITION (current_binding_level != NULL);
int l = vec_safe_length (current_binding_level->m2_statements) - 1;
return &(*current_binding_level->m2_statements)[l];
}
tree
m2block_cur_stmt_list (void)
{
tree *t = m2block_cur_stmt_list_addr ();
return *t;
}
/* is_building_stmt_list - returns TRUE if we are building a
statement list. TRUE is returned if we are in a binding level and
a statement list is under construction. */
int
m2block_is_building_stmt_list (void)
{
ASSERT_CONDITION (current_binding_level != NULL);
return !vec_safe_is_empty (current_binding_level->m2_statements);
}
/* push_statement_list - pushes the statement list, t, onto the
current binding level. */
tree
m2block_push_statement_list (tree t)
{
ASSERT_CONDITION (current_binding_level != NULL);
vec_safe_push (current_binding_level->m2_statements, t);
return t;
}
/* pop_statement_list - pops and returns a statement list from the
current binding level. */
tree
m2block_pop_statement_list (void)
{
ASSERT_CONDITION (current_binding_level != NULL);
{
tree t = current_binding_level->m2_statements->pop ();
return t;
}
}
/* begin_statement_list - starts a tree statement. It pushes the
statement list and returns the list node. */
tree
m2block_begin_statement_list (void)
{
return alloc_stmt_list ();
}
/* end_statement_list - returns the current statement tree. The
current statement tree is popped from the statement stack and the
list node is returned. */
tree
m2block_end_statement_list (tree t)
{
/* should we do anything with, t? Specifically we may need to test
for the presence of a label --fixme-- check this */
return t;
}
/* findLevel - returns the binding level associated with, fndecl, one
is created if there is no existing one on head_binding_level. */
static struct binding_level *
findLevel (tree fndecl)
{
struct binding_level *b;
if (fndecl == NULL_TREE)
return global_binding_level;
b = head_binding_level;
while ((b != NULL) && (b->fndecl != fndecl))
b = b->list;
if (b == NULL)
{
b = newLevel ();
b->fndecl = fndecl;
b->context = fndecl;
b->is_global = FALSE;
b->list = head_binding_level;
b->next = NULL;
}
return b;
}
/* pushFunctionScope - push a binding level. */
void
m2block_pushFunctionScope (tree fndecl)
{
struct binding_level *n;
struct binding_level *b;
#if defined(DEBUGGING)
if (fndecl != NULL)
printf ("pushFunctionScope\n");
#endif
/* allow multiple consecutive pushes of the same scope. */
if (current_binding_level != NULL
&& (current_binding_level->fndecl == fndecl))
{
current_binding_level->count++;
return;
}
/* firstly check to see that fndecl is not already on the binding
stack. */
for (b = current_binding_level; b != NULL; b = b->next)
/* only allowed one instance of the binding on the stack at a time. */
ASSERT_CONDITION (b->fndecl != fndecl);
n = findLevel (fndecl);
/* Add this level to the front of the stack. */
n->next = current_binding_level;
current_binding_level = n;
}
/* popFunctionScope - pops a binding level, returning the function
associated with the binding level. */
tree
m2block_popFunctionScope (void)
{
tree fndecl = current_binding_level->fndecl;
#if defined(DEBUGGING)
if (fndecl != NULL)
printf ("popFunctionScope\n");
#endif
if (current_binding_level->count > 0)
{
/* multiple pushes have occurred of the same function scope (and
ignored), pop them likewise. */
current_binding_level->count--;
return fndecl;
}
ASSERT_CONDITION (current_binding_level->fndecl
!= NULL_TREE); /* expecting local scope. */
ASSERT_CONDITION (current_binding_level->constants
== NULL_TREE); /* should not be used. */
ASSERT_CONDITION (current_binding_level->names
== NULL_TREE); /* should be cleared. */
ASSERT_CONDITION (current_binding_level->decl
== NULL_TREE); /* should be cleared. */
current_binding_level = current_binding_level->next;
return fndecl;
}
/* pushGlobalScope - push the global scope onto the binding level
stack. There can only ever be one instance of the global binding
level on the stack. */
void
m2block_pushGlobalScope (void)
{
#if defined(DEBUGGING)
printf ("pushGlobalScope\n");
#endif
m2block_pushFunctionScope (NULL_TREE);
}
/* popGlobalScope - pops the current binding level, it expects this
binding level to be the global binding level. */
void
m2block_popGlobalScope (void)
{
ASSERT_CONDITION (
current_binding_level->is_global); /* expecting global scope. */
ASSERT_CONDITION (current_binding_level == global_binding_level);
if (current_binding_level->count > 0)
{
current_binding_level->count--;
return;
}
current_binding_level = current_binding_level->next;
#if defined(DEBUGGING)
printf ("popGlobalScope\n");
#endif
assert_global_names ();
}
/* finishFunctionDecl - removes declarations from the current binding
level and places them inside fndecl. The current binding level is
then able to be destroyed by a call to popFunctionScope.
The extra tree nodes associated with fndecl will be created such
as BIND_EXPR, BLOCK and the initial STATEMENT_LIST containing the
DECL_EXPR is also created. */
void
m2block_finishFunctionDecl (location_t location, tree fndecl)
{
tree context = current_binding_level->context;
tree block = DECL_INITIAL (fndecl);
tree bind_expr = DECL_SAVED_TREE (fndecl);
tree i;
if (block == NULL_TREE)
{
block = make_node (BLOCK);
DECL_INITIAL (fndecl) = block;
TREE_USED (block) = TRUE;
BLOCK_SUBBLOCKS (block) = NULL_TREE;
}
BLOCK_SUPERCONTEXT (block) = context;
BLOCK_VARS (block)
= chainon (BLOCK_VARS (block), current_binding_level->names);
TREE_USED (fndecl) = TRUE;
if (bind_expr == NULL_TREE)
{
bind_expr
= build3 (BIND_EXPR, void_type_node, current_binding_level->names,
current_binding_level->decl, block);
DECL_SAVED_TREE (fndecl) = bind_expr;
}
else
{
if (!chain_member (current_binding_level->names,
BIND_EXPR_VARS (bind_expr)))
{
BIND_EXPR_VARS (bind_expr) = chainon (BIND_EXPR_VARS (bind_expr),
current_binding_level->names);
if (current_binding_level->names != NULL_TREE)
{
for (i = current_binding_level->names; i != NULL_TREE;
i = DECL_CHAIN (i))
append_to_statement_list_force (i,
&BIND_EXPR_BODY (bind_expr));
}
}
}
SET_EXPR_LOCATION (bind_expr, location);
current_binding_level->names = NULL_TREE;
current_binding_level->decl = NULL_TREE;
}
/* finishFunctionCode - adds cur_stmt_list to fndecl. The current
binding level is then able to be destroyed by a call to
popFunctionScope. The cur_stmt_list is appended to the
STATEMENT_LIST. */
void
m2block_finishFunctionCode (tree fndecl)
{
tree bind_expr;
tree block;
tree statements = m2block_pop_statement_list ();
tree_stmt_iterator i;
statements = m2block_end_statement_list (statements);
ASSERT_CONDITION (DECL_SAVED_TREE (fndecl) != NULL_TREE);
bind_expr = DECL_SAVED_TREE (fndecl);
ASSERT_CONDITION (TREE_CODE (bind_expr) == BIND_EXPR);
block = DECL_INITIAL (fndecl);
ASSERT_CONDITION (TREE_CODE (block) == BLOCK);
if (current_binding_level->names != NULL_TREE)
{
BIND_EXPR_VARS (bind_expr)
= chainon (BIND_EXPR_VARS (bind_expr), current_binding_level->names);
current_binding_level->names = NULL_TREE;
}
if (current_binding_level->labels != NULL_TREE)
{
tree t;
for (t = current_binding_level->labels; t != NULL_TREE;
t = TREE_CHAIN (t))
{
tree l = TREE_VALUE (t);
BIND_EXPR_VARS (bind_expr) = chainon (BIND_EXPR_VARS (bind_expr), l);
}
current_binding_level->labels = NULL_TREE;
}
BLOCK_VARS (block) = BIND_EXPR_VARS (bind_expr);
if (current_binding_level->decl != NULL_TREE)
for (i = tsi_start (current_binding_level->decl); !tsi_end_p (i);
tsi_next (&i))
append_to_statement_list_force (*tsi_stmt_ptr (i),
&BIND_EXPR_BODY (bind_expr));
for (i = tsi_start (statements); !tsi_end_p (i); tsi_next (&i))
append_to_statement_list_force (*tsi_stmt_ptr (i),
&BIND_EXPR_BODY (bind_expr));
current_binding_level->decl = NULL_TREE;
}
void
m2block_finishGlobals (void)
{
tree context = global_binding_level->context;
tree block = make_node (BLOCK);
tree p = global_binding_level->names;
BLOCK_SUBBLOCKS (block) = NULL;
TREE_USED (block) = 1;
BLOCK_VARS (block) = p;
DECL_INITIAL (context) = block;
BLOCK_SUPERCONTEXT (block) = context;
}
/* pushDecl - pushes a declaration onto the current binding level. */
tree
m2block_pushDecl (tree decl)
{
/* External objects aren't nested, other objects may be. */
if (decl != current_function_decl)
DECL_CONTEXT (decl) = current_binding_level->context;
/* Put the declaration on the list. The list of declarations is in
reverse order. The list will be reversed later if necessary. This
needs to be this way for compatibility with the back-end. */
TREE_CHAIN (decl) = current_binding_level->names;
current_binding_level->names = decl;
assert_global_names ();
return decl;
}
/* includeDecl - pushes a declaration onto the current binding level
providing it is not already present. */
void
m2block_includeDecl (tree decl)
{
tree p = current_binding_level->names;
while (p != decl && p != NULL)
p = TREE_CHAIN (p);
if (p != decl)
m2block_pushDecl (decl);
}
/* addDeclExpr - adds the DECL_EXPR node, t, to the statement list
current_binding_level->decl. This allows us to order all
declarations at the beginning of the function. */
void
m2block_addDeclExpr (tree t)
{
append_to_statement_list_force (t, ¤t_binding_level->decl);
}
/* RememberType - remember the type, t, in the ggc marked list. */
tree
m2block_RememberType (tree t)
{
global_binding_level->types
= tree_cons (NULL_TREE, t, global_binding_level->types);
return t;
}
/* global_constant - returns t. It chains, t, onto the
global_binding_level list of constants, if it is not already
present. */
tree
m2block_global_constant (tree t)
{
tree s;
if (global_binding_level->constants != NULL_TREE)
for (s = global_binding_level->constants; s != NULL_TREE;
s = TREE_CHAIN (s))
{
tree c = TREE_VALUE (s);
if (c == t)
return t;
}
global_binding_level->constants
= tree_cons (NULL_TREE, t, global_binding_level->constants);
return t;
}
/* RememberConstant - adds a tree, t, onto the list of constants to
be marked whenever the ggc re-marks all used storage. Constants
live throughout the whole compilation - and they can be used by
many different functions if necessary. */
tree
m2block_RememberConstant (tree t)
{
if ((t != NULL) && (m2tree_IsAConstant (t)))
return m2block_global_constant (t);
return t;
}
/* DumpGlobalConstants - displays all global constants and checks
none are poisoned. */
tree
m2block_DumpGlobalConstants (void)
{
tree s;
if (global_binding_level->constants != NULL_TREE)
for (s = global_binding_level->constants; TREE_CHAIN (s);
s = TREE_CHAIN (s))
debug_tree (s);
return NULL_TREE;
}
/* RememberInitModuleFunction - records tree, t, in the global
binding level. So that it will not be garbage collected. In
theory the inner modules could be placed inside the
current_binding_level I suspect. */
tree
m2block_RememberInitModuleFunction (tree t)
{
global_binding_level->init_functions
= tree_cons (NULL_TREE, t, global_binding_level->init_functions);
return t;
}
/* toplevel - return TRUE if we are in the global scope. */
int
m2block_toplevel (void)
{
if (current_binding_level == NULL)
return TRUE;
if (current_binding_level->fndecl == NULL)
return TRUE;
return FALSE;
}
/* GetErrorNode - returns the gcc error_mark_node. */
tree
m2block_GetErrorNode (void)
{
return error_mark_node;
}
/* GetGlobals - returns a list of global variables, functions,
constants. */
tree
m2block_GetGlobals (void)
{
assert_global_names ();
return global_binding_level->names;
}
/* GetGlobalContext - returns the global context tree. */
tree
m2block_GetGlobalContext (void)
{
return global_binding_level->context;
}
/* do_add_stmt - t is a statement. Add it to the statement-tree. */
static tree
do_add_stmt (tree t)
{
if (current_binding_level != NULL)
append_to_statement_list_force (t, m2block_cur_stmt_list_addr ());
return t;
}
/* flush_pending_note - flushes a pending_statement note if
necessary. */
static void
flush_pending_note (void)
{
if (pending_statement && (M2Options_GetM2g ()))
{
#if 0
/* --fixme-- we need a machine independant way to generate a nop. */
tree instr = m2decl_BuildStringConstant ("nop", 3);
tree string
= resolve_asm_operand_names (instr, NULL_TREE, NULL_TREE, NULL_TREE);
tree note = build_stmt (pending_location, ASM_EXPR, string, NULL_TREE,
NULL_TREE, NULL_TREE, NULL_TREE);
ASM_INPUT_P (note) = FALSE;
ASM_VOLATILE_P (note) = FALSE;
#else
tree note = build_empty_stmt (pending_location);
#endif
pending_statement = FALSE;
do_add_stmt (note);
}
}
/* add_stmt - t is a statement. Add it to the statement-tree. */
tree
m2block_add_stmt (location_t location, tree t)
{
if ((CAN_HAVE_LOCATION_P (t)) && (!EXPR_HAS_LOCATION (t)))
SET_EXPR_LOCATION (t, location);
if (pending_statement && (pending_location != location))
flush_pending_note ();
pending_statement = FALSE;
return do_add_stmt (t);
}
/* addStmtNote - remember this location represents the start of a
Modula-2 statement. It is flushed if another different location
is generated or another tree is given to add_stmt. */
void
m2block_addStmtNote (location_t location)
{
if (pending_statement && (pending_location != location))
flush_pending_note ();
pending_statement = TRUE;
pending_location = location;
}
void
m2block_removeStmtNote (void)
{
pending_statement = FALSE;
}
/* init - initialise the data structures in this module. */
void
m2block_init (void)
{
global_binding_level = newLevel ();
global_binding_level->context = build_translation_unit_decl (NULL);
global_binding_level->is_global = TRUE;
current_binding_level = NULL;
}
#include "gt-m2-m2block.h"
------------------------
New file: gcc/m2/gm2-gcc/m2color.h
------------------------
/* m2color.h 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/>. */
#if !defined(m2color_h)
#define m2color_h
#if defined(m2color_c)
#if defined(__GNUG__)
#define EXTERN extern "C"
#else /* !__GNUG__. */
#define EXTERN
#endif /* !__GNUG__. */
#else /* !m2color_c. */
#if defined(__GNUG__)
#define EXTERN extern "C"
#else /* !__GNUG__. */
#define EXTERN extern
#endif /* !__GNUG__. */
#endif /* !m2color_c. */
EXTERN const char *m2color_colorize_start (bool show_color, char *name, unsigned int name_len);
EXTERN const char *m2color_colorize_stop (bool show_color);
EXTERN const char *m2color_open_quote (void);
EXTERN const char *m2color_close_quote (void);
EXTERN void _M2_m2color_init ();
EXTERN void _M2_m2color_finish ();
#endif
------------------------
New file: gcc/m2/gm2-gcc/m2misc.cc
------------------------
/* m2misc.cc miscellaneous tree debugging 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 "../m2-tree.h"
#include "tree-iterator.h"
#define m2misc_c
#include "m2block.h"
#include "m2misc.h"
#include "m2tree.h"
/* DebugTree - display the tree, t. */
void
m2misc_DebugTree (tree t)
{
debug_tree (t);
}
/* DebugTree - display the tree, t. */
void
m2misc_DebugTreeChain (tree t)
{
for (; (t != NULL); t = TREE_CHAIN (t))
debug_tree (t);
}
/* DebugTree - display the tree, t. */
void
m2misc_printStmt (void)
{
if (m2block_cur_stmt_list () != NULL)
debug_tree (m2block_cur_stmt_list ());
}
------------------------
New file: gcc/m2/gm2-gcc/m2expr.cc
------------------------
/* m2expr.cc provides an interface to GCC expression 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"
#include "m2convert.h"
/* prototypes. */
#define m2expr_c
#include "m2assert.h"
#include "m2builtins.h"
#include "m2convert.h"
#include "m2decl.h"
#include "m2expr.h"
#include "m2options.h"
#include "m2range.h"
#include "m2statement.h"
#include "m2tree.h"
#include "m2treelib.h"
#include "m2type.h"
static void m2expr_checkRealOverflow (location_t location, enum tree_code code,
tree result);
static tree checkWholeNegateOverflow (location_t location, tree i, tree lowest,
tree min, tree max);
// static tree m2expr_Build4LogicalAnd (location_t location, tree a, tree b,
// tree c, tree d);
static tree m2expr_Build4LogicalOr (location_t location, tree a, tree b,
tree c, tree d);
static tree m2expr_Build4TruthOrIf (location_t location, tree a, tree b,
tree c, tree d);
static tree m2expr_Build4TruthAndIf (location_t location, tree a, tree b,
tree c, tree d);
static int label_count = 0;
static GTY (()) tree set_full_complement;
/* CompareTrees returns -1 if e1 < e2, 0 if e1 == e2, and 1 if e1 > e2. */
int
m2expr_CompareTrees (tree e1, tree e2)
{
return tree_int_cst_compare (m2expr_FoldAndStrip (e1),
m2expr_FoldAndStrip (e2));
}
/* FoldAndStrip return expression, t, after it has been folded (if
possible). */
tree
m2expr_FoldAndStrip (tree t)
{
if (t != NULL)
{
t = fold (t);
if (TREE_CODE (t) == CONST_DECL)
return m2expr_FoldAndStrip (DECL_INITIAL (t));
}
return t;
}
/* StringLength returns an unsigned int which is the length of, string. */
unsigned int
m2expr_StringLength (tree string)
{
return TREE_STRING_LENGTH (string);
}
/* CheckAddressToCardinal if op is a pointer convert it to the ADDRESS type. */
static tree
CheckAddressToCardinal (location_t location, tree op)
{
if (m2type_IsAddress (TREE_TYPE (op)))
return m2convert_BuildConvert (location, m2type_GetCardinalAddressType (),
op, FALSE);
return op;
}
/* BuildTruthAndIf return TRUE if a && b. Retain order left to right. */
static tree
m2expr_BuildTruthAndIf (location_t location, tree a, tree b)
{
return m2expr_build_binary_op (location, TRUTH_ANDIF_EXPR, a, b, FALSE);
}
/* BuildTruthOrIf return TRUE if a || b. Retain order left to right. */
static tree
m2expr_BuildTruthOrIf (location_t location, tree a, tree b)
{
return m2expr_build_binary_op (location, TRUTH_ORIF_EXPR, a, b, FALSE);
}
/* BuildTruthNotIf inverts the boolean value of expr and returns the result. */
static tree
m2expr_BuildTruthNot (location_t location, tree expr)
{
return m2expr_build_unary_op (location, TRUTH_NOT_EXPR, expr, FALSE);
}
/* BuildPostInc builds a post increment tree, the second operand is
always one. */
static tree
m2expr_BuildPostInc (location_t location, tree op)
{
return m2expr_BuildAdd (location, op, build_int_cst (TREE_TYPE (op), 1), FALSE);
}
/* BuildPostDec builds a post decrement tree, the second operand is
always one. */
static tree
m2expr_BuildPostDec (location_t location, tree op)
{
return m2expr_BuildSub (location, op, build_int_cst (TREE_TYPE (op), 1), FALSE);
}
/* BuildAddCheck builds an addition tree. */
tree
m2expr_BuildAddCheck (location_t location, tree op1, tree op2, tree lowest,
tree min, tree max)
{
tree t;
m2assert_AssertLocation (location);
op1 = m2expr_FoldAndStrip (op1);
op2 = m2expr_FoldAndStrip (op2);
op1 = CheckAddressToCardinal (location, op1);
op2 = CheckAddressToCardinal (location, op2);
t = m2expr_build_binary_op_check (location, PLUS_EXPR, op1, op2, FALSE,
lowest, min, max);
return m2expr_FoldAndStrip (t);
}
/* BuildAdd builds an addition tree. */
tree
m2expr_BuildAdd (location_t location, tree op1, tree op2, int needconvert)
{
tree t;
m2assert_AssertLocation (location);
op1 = m2expr_FoldAndStrip (op1);
op2 = m2expr_FoldAndStrip (op2);
op1 = CheckAddressToCardinal (location, op1);
op2 = CheckAddressToCardinal (location, op2);
t = m2expr_build_binary_op (location, PLUS_EXPR, op1, op2, needconvert);
return m2expr_FoldAndStrip (t);
}
/* BuildSubCheck builds a subtraction tree. */
tree
m2expr_BuildSubCheck (location_t location, tree op1, tree op2, tree lowest,
tree min, tree max)
{
tree t;
m2assert_AssertLocation (location);
op1 = m2expr_FoldAndStrip (op1);
op2 = m2expr_FoldAndStrip (op2);
op1 = CheckAddressToCardinal (location, op1);
op2 = CheckAddressToCardinal (location, op2);
t = m2expr_build_binary_op_check (location, MINUS_EXPR, op1, op2, FALSE,
lowest, min, max);
return m2expr_FoldAndStrip (t);
}
/* BuildSub builds a subtraction tree. */
tree
m2expr_BuildSub (location_t location, tree op1, tree op2, int needconvert)
{
tree t;
m2assert_AssertLocation (location);
op1 = m2expr_FoldAndStrip (op1);
op2 = m2expr_FoldAndStrip (op2);
op1 = CheckAddressToCardinal (location, op1);
op2 = CheckAddressToCardinal (location, op2);
t = m2expr_build_binary_op (location, MINUS_EXPR, op1, op2, needconvert);
return m2expr_FoldAndStrip (t);
}
/* BuildDivTrunc builds a trunc division tree. */
tree
m2expr_BuildDivTrunc (location_t location, tree op1, tree op2, int needconvert)
{
tree t;
m2assert_AssertLocation (location);
op1 = m2expr_FoldAndStrip (op1);
op2 = m2expr_FoldAndStrip (op2);
op1 = CheckAddressToCardinal (location, op1);
op2 = CheckAddressToCardinal (location, op2);
t = m2expr_build_binary_op (location, TRUNC_DIV_EXPR, op1, op2, needconvert);
return m2expr_FoldAndStrip (t);
}
/* BuildDivTruncCheck builds a trunc division tree. */
tree
m2expr_BuildDivTruncCheck (location_t location, tree op1, tree op2, tree lowest,
tree min, tree max)
{
tree t;
m2assert_AssertLocation (location);
op1 = m2expr_FoldAndStrip (op1);
op2 = m2expr_FoldAndStrip (op2);
op1 = CheckAddressToCardinal (location, op1);
op2 = CheckAddressToCardinal (location, op2);
t = m2expr_build_binary_op_check (location, TRUNC_DIV_EXPR, op1, op2, FALSE,
lowest, min, max);
return m2expr_FoldAndStrip (t);
}
/* BuildModTruncCheck builds a trunc modulus tree. */
tree
m2expr_BuildModTruncCheck (location_t location, tree op1, tree op2, tree lowest,
tree min, tree max)
{
tree t;
m2assert_AssertLocation (location);
op1 = m2expr_FoldAndStrip (op1);
op2 = m2expr_FoldAndStrip (op2);
op1 = CheckAddressToCardinal (location, op1);
op2 = CheckAddressToCardinal (location, op2);
t = m2expr_build_binary_op_check (location, TRUNC_MOD_EXPR, op1, op2, FALSE,
lowest, min, max);
return m2expr_FoldAndStrip (t);
}
/* BuildModTrunc builds a trunc modulus tree. */
tree
m2expr_BuildModTrunc (location_t location, tree op1, tree op2, int needconvert)
{
tree t;
m2assert_AssertLocation (location);
op1 = m2expr_FoldAndStrip (op1);
op2 = m2expr_FoldAndStrip (op2);
op1 = CheckAddressToCardinal (location, op1);
op2 = CheckAddressToCardinal (location, op2);
t = m2expr_build_binary_op (location, TRUNC_MOD_EXPR, op1, op2, needconvert);
return m2expr_FoldAndStrip (t);
}
/* BuildModCeilCheck builds a ceil modulus tree. */
tree
m2expr_BuildModCeilCheck (location_t location, tree op1, tree op2, tree lowest,
tree min, tree max)
{
tree t;
m2assert_AssertLocation (location);
op1 = m2expr_FoldAndStrip (op1);
op2 = m2expr_FoldAndStrip (op2);
op1 = CheckAddressToCardinal (location, op1);
op2 = CheckAddressToCardinal (location, op2);
t = m2expr_build_binary_op_check (location, CEIL_MOD_EXPR, op1, op2, FALSE,
lowest, min, max);
return m2expr_FoldAndStrip (t);
}
/* BuildModFloorCheck builds a trunc modulus tree. */
tree
m2expr_BuildModFloorCheck (location_t location, tree op1, tree op2, tree lowest,
tree min, tree max)
{
tree t;
m2assert_AssertLocation (location);
op1 = m2expr_FoldAndStrip (op1);
op2 = m2expr_FoldAndStrip (op2);
op1 = CheckAddressToCardinal (location, op1);
op2 = CheckAddressToCardinal (location, op2);
t = m2expr_build_binary_op_check (location, FLOOR_MOD_EXPR, op1, op2, FALSE,
lowest, min, max);
return m2expr_FoldAndStrip (t);
}
/* BuildDivCeil builds a ceil division tree. */
tree
m2expr_BuildDivCeil (location_t location, tree op1, tree op2, int needconvert)
{
tree t;
m2assert_AssertLocation (location);
op1 = m2expr_FoldAndStrip (op1);
op2 = m2expr_FoldAndStrip (op2);
op1 = CheckAddressToCardinal (location, op1);
op2 = CheckAddressToCardinal (location, op2);
t = m2expr_build_binary_op (location, CEIL_DIV_EXPR, op1, op2, needconvert);
return m2expr_FoldAndStrip (t);
}
/* BuildDivCeilCheck builds a check ceil division tree. */
tree
m2expr_BuildDivCeilCheck (location_t location, tree op1, tree op2, tree lowest,
tree min, tree max)
{
tree t;
m2assert_AssertLocation (location);
op1 = m2expr_FoldAndStrip (op1);
op2 = m2expr_FoldAndStrip (op2);
op1 = CheckAddressToCardinal (location, op1);
op2 = CheckAddressToCardinal (location, op2);
t = m2expr_build_binary_op_check (location, CEIL_DIV_EXPR, op1, op2, FALSE,
lowest, min, max);
return m2expr_FoldAndStrip (t);
}
/* BuildModCeil builds a ceil modulus tree. */
tree
m2expr_BuildModCeil (location_t location, tree op1, tree op2, int needconvert)
{
tree t;
m2assert_AssertLocation (location);
op1 = m2expr_FoldAndStrip (op1);
op2 = m2expr_FoldAndStrip (op2);
op1 = CheckAddressToCardinal (location, op1);
op2 = CheckAddressToCardinal (location, op2);
t = m2expr_build_binary_op (location, CEIL_MOD_EXPR, op1, op2, needconvert);
return m2expr_FoldAndStrip (t);
}
/* BuildDivFloor builds a floor division tree. */
tree
m2expr_BuildDivFloor (location_t location, tree op1, tree op2, int needconvert)
{
tree t;
m2assert_AssertLocation (location);
op1 = m2expr_FoldAndStrip (op1);
op2 = m2expr_FoldAndStrip (op2);
op1 = CheckAddressToCardinal (location, op1);
op2 = CheckAddressToCardinal (location, op2);
t = m2expr_build_binary_op (location, FLOOR_DIV_EXPR, op1, op2, needconvert);
return m2expr_FoldAndStrip (t);
}
/* BuildDivFloorCheck builds a check floor division tree. */
tree
m2expr_BuildDivFloorCheck (location_t location, tree op1, tree op2, tree lowest,
tree min, tree max)
{
tree t;
m2assert_AssertLocation (location);
op1 = m2expr_FoldAndStrip (op1);
op2 = m2expr_FoldAndStrip (op2);
op1 = CheckAddressToCardinal (location, op1);
op2 = CheckAddressToCardinal (location, op2);
t = m2expr_build_binary_op_check (location, FLOOR_DIV_EXPR, op1, op2, FALSE,
lowest, min, max);
return m2expr_FoldAndStrip (t);
}
/* BuildRDiv builds a division tree (this should only be used for
REAL and COMPLEX types and NEVER for integer based types). */
tree
m2expr_BuildRDiv (location_t location, tree op1, tree op2, int needconvert)
{
tree t;
m2assert_AssertLocation (location);
op1 = m2expr_FoldAndStrip (op1);
op2 = m2expr_FoldAndStrip (op2);
t = m2expr_build_binary_op (location, RDIV_EXPR, op1, op2, needconvert);
return m2expr_FoldAndStrip (t);
}
/* BuildModFloor builds a modulus tree. */
tree
m2expr_BuildModFloor (location_t location, tree op1, tree op2, int needconvert)
{
tree t;
m2assert_AssertLocation (location);
op1 = m2expr_FoldAndStrip (op1);
op2 = m2expr_FoldAndStrip (op2);
op1 = CheckAddressToCardinal (location, op1);
op2 = CheckAddressToCardinal (location, op2);
t = m2expr_build_binary_op (location, FLOOR_MOD_EXPR, op1, op2, needconvert);
return m2expr_FoldAndStrip (t);
}
/* BuildLSL builds and returns tree (op1 << op2). */
tree
m2expr_BuildLSL (location_t location, tree op1, tree op2, int needconvert)
{
tree t;
m2assert_AssertLocation (location);
op1 = m2expr_FoldAndStrip (op1);
op2 = m2expr_FoldAndStrip (op2);
t = m2expr_build_binary_op (location, LSHIFT_EXPR, op1, op2, needconvert);
return m2expr_FoldAndStrip (t);
}
/* BuildLSR builds and returns tree (op1 >> op2). */
tree
m2expr_BuildLSR (location_t location, tree op1, tree op2, int needconvert)
{
tree t;
m2assert_AssertLocation (location);
op1 = m2expr_FoldAndStrip (op1);
op2 = m2expr_FoldAndStrip (op2);
t = m2expr_build_binary_op (location, RSHIFT_EXPR, op1, op2, needconvert);
return m2expr_FoldAndStrip (t);
}
/* createUniqueLabel returns a unique label which has been alloc'ed. */
static char *
createUniqueLabel (void)
{
int size, i;
char *label;
label_count++;
i = label_count;
size = strlen (".LSHIFT") + 2;
while (i > 0)
{
i /= 10;
size++;
}
label = (char *)ggc_alloc_atomic (size);
sprintf (label, ".LSHIFT%d", label_count);
return label;
}
/* BuildLogicalShift builds the ISO Modula-2 SHIFT operator for a
fundamental data type. */
void
m2expr_BuildLogicalShift (location_t location, tree op1, tree op2, tree op3,
tree nBits ATTRIBUTE_UNUSED, int needconvert)
{
tree res;
m2assert_AssertLocation (location);
op2 = m2expr_FoldAndStrip (op2);
op3 = m2expr_FoldAndStrip (op3);
if (TREE_CODE (op3) == INTEGER_CST)
{
op2 = m2convert_ToWord (location, op2);
if (tree_int_cst_sgn (op3) < 0)
res = m2expr_BuildLSR (
location, op2,
m2convert_ToWord (location,
m2expr_BuildNegate (location, op3, needconvert)),
needconvert);
else
res = m2expr_BuildLSL (location, op2, m2convert_ToWord (location, op3),
needconvert);
res = m2convert_BuildConvert (
location, m2tree_skip_type_decl (TREE_TYPE (op1)), res, FALSE);
m2statement_BuildAssignmentTree (location, op1, res);
}
else
{
char *labelElseName = createUniqueLabel ();
char *labelEndName = createUniqueLabel ();
tree is_less = m2expr_BuildLessThan (location,
m2convert_ToInteger (location, op3),
m2expr_GetIntegerZero (location));
m2statement_DoJump (location, is_less, NULL, labelElseName);
op2 = m2convert_ToWord (location, op2);
op3 = m2convert_ToWord (location, op3);
res = m2expr_BuildLSL (location, op2, op3, needconvert);
res = m2convert_BuildConvert (
location, m2tree_skip_type_decl (TREE_TYPE (op1)), res, FALSE);
m2statement_BuildAssignmentTree (location, op1, res);
m2statement_BuildGoto (location, labelEndName);
m2statement_DeclareLabel (location, labelElseName);
res = m2expr_BuildLSR (location, op2,
m2expr_BuildNegate (location, op3, needconvert),
needconvert);
res = m2convert_BuildConvert (
location, m2tree_skip_type_decl (TREE_TYPE (op1)), res, FALSE);
m2statement_BuildAssignmentTree (location, op1, res);
m2statement_DeclareLabel (location, labelEndName);
}
}
/* BuildLRL builds and returns tree (op1 rotate left by op2 bits). */
tree
m2expr_BuildLRL (location_t location, tree op1, tree op2, int needconvert)
{
tree t;
m2assert_AssertLocation (location);
op1 = m2expr_FoldAndStrip (op1);
op2 = m2expr_FoldAndStrip (op2);
t = m2expr_build_binary_op (location, LROTATE_EXPR, op1, op2, needconvert);
return m2expr_FoldAndStrip (t);
}
/* BuildLRR builds and returns tree (op1 rotate right by op2 bits). */
tree
m2expr_BuildLRR (location_t location, tree op1, tree op2, int needconvert)
{
tree t;
m2assert_AssertLocation (location);
op1 = m2expr_FoldAndStrip (op1);
op2 = m2expr_FoldAndStrip (op2);
t = m2expr_build_binary_op (location, RROTATE_EXPR, op1, op2, needconvert);
return m2expr_FoldAndStrip (t);
}
/* m2expr_BuildMask returns a tree for the mask of a set of nBits.
It assumes nBits is <= TSIZE (WORD). */
tree
m2expr_BuildMask (location_t location, tree nBits, int needconvert)
{
tree mask = m2expr_BuildLSL (location, m2expr_GetIntegerOne (location),
nBits, needconvert);
m2assert_AssertLocation (location);
return m2expr_BuildSub (location, mask, m2expr_GetIntegerOne (location),
needconvert);
}
/* m2expr_BuildLRotate returns a tree in which op1 has been left
rotated by nBits. It assumes nBits is <= TSIZE (WORD). */
tree
m2expr_BuildLRotate (location_t location, tree op1, tree nBits,
int needconvert)
{
tree t;
op1 = m2expr_FoldAndStrip (op1);
nBits = m2expr_FoldAndStrip (nBits);
t = m2expr_build_binary_op (location, LROTATE_EXPR, op1, nBits, needconvert);
return m2expr_FoldAndStrip (t);
}
/* m2expr_BuildRRotate returns a tree in which op1 has been left
rotated by nBits. It assumes nBits is <= TSIZE (WORD). */
tree
m2expr_BuildRRotate (location_t location, tree op1, tree nBits,
int needconvert)
{
tree t;
op1 = m2expr_FoldAndStrip (op1);
nBits = m2expr_FoldAndStrip (nBits);
t = m2expr_build_binary_op (location, RROTATE_EXPR, op1, nBits, needconvert);
return m2expr_FoldAndStrip (t);
}
/* BuildLRLn builds and returns tree (op1 rotate left by op2 bits) it
rotates a set of size, nBits. */
tree
m2expr_BuildLRLn (location_t location, tree op1, tree op2, tree nBits,
int needconvert)
{
tree op2min;
m2assert_AssertLocation (location);
/* ensure we wrap the rotate. */
op2min = m2expr_BuildModTrunc (
location, m2convert_ToCardinal (location, op2),
m2convert_ToCardinal (location, nBits), needconvert);
/* optimize if we are we going to rotate a TSIZE(BITSET) set. */
if (m2expr_CompareTrees (
m2decl_BuildIntegerConstant (m2decl_GetBitsPerBitset ()), nBits)
== 0)
return m2expr_BuildLRotate (location, op1, op2min, needconvert);
else
{
tree mask = m2expr_BuildMask (location, nBits, needconvert);
tree left, right;
/* make absolutely sure there are no high order bits lying around. */
op1 = m2expr_BuildLogicalAnd (location, op1, mask, needconvert);
left = m2expr_BuildLSL (location, op1, op2min, needconvert);
left = m2expr_BuildLogicalAnd (location, left, mask, needconvert);
right = m2expr_BuildLSR (
location, op1,
m2expr_BuildSub (location, m2convert_ToCardinal (location, nBits),
op2min, needconvert),
needconvert);
return m2expr_BuildLogicalOr (location, left, right, needconvert);
}
}
/* BuildLRRn builds and returns tree (op1 rotate right by op2 bits).
It rotates a set of size, nBits. */
tree
m2expr_BuildLRRn (location_t location, tree op1, tree op2, tree nBits,
int needconvert)
{
tree op2min;
m2assert_AssertLocation (location);
/* ensure we wrap the rotate. */
op2min = m2expr_BuildModTrunc (
location, m2convert_ToCardinal (location, op2),
m2convert_ToCardinal (location, nBits), needconvert);
/* optimize if we are we going to rotate a TSIZE(BITSET) set. */
if (m2expr_CompareTrees (
m2decl_BuildIntegerConstant (m2decl_GetBitsPerBitset ()), nBits)
== 0)
return m2expr_BuildRRotate (location, op1, op2min, needconvert);
else
{
tree mask = m2expr_BuildMask (location, nBits, needconvert);
tree left, right;
/* make absolutely sure there are no high order bits lying around. */
op1 = m2expr_BuildLogicalAnd (location, op1, mask, needconvert);
right = m2expr_BuildLSR (location, op1, op2min, needconvert);
left = m2expr_BuildLSL (
location, op1,
m2expr_BuildSub (location, m2convert_ToCardinal (location, nBits),
op2min, needconvert),
needconvert);
left = m2expr_BuildLogicalAnd (location, left, mask, needconvert);
return m2expr_BuildLogicalOr (location, left, right, needconvert);
}
}
/* BuildLogicalRotate build the ISO Modula-2 ROTATE operator for a
fundamental data type. */
void
m2expr_BuildLogicalRotate (location_t location, tree op1, tree op2, tree op3,
tree nBits, int needconvert)
{
tree res;
m2assert_AssertLocation (location);
op2 = m2expr_FoldAndStrip (op2);
op3 = m2expr_FoldAndStrip (op3);
if (TREE_CODE (op3) == INTEGER_CST)
{
if (tree_int_cst_sgn (op3) < 0)
res = m2expr_BuildLRRn (
location, op2, m2expr_BuildNegate (location, op3, needconvert),
nBits, needconvert);
else
res = m2expr_BuildLRLn (location, op2, op3, nBits, needconvert);
m2statement_BuildAssignmentTree (location, op1, res);
}
else
{
char *labelElseName = createUniqueLabel ();
char *labelEndName = createUniqueLabel ();
tree is_less = m2expr_BuildLessThan (location,
m2convert_ToInteger (location, op3),
m2expr_GetIntegerZero (location));
m2statement_DoJump (location, is_less, NULL, labelElseName);
res = m2expr_BuildLRLn (location, op2, op3, nBits, needconvert);
m2statement_BuildAssignmentTree (location, op1, res);
m2statement_BuildGoto (location, labelEndName);
m2statement_DeclareLabel (location, labelElseName);
res = m2expr_BuildLRRn (location, op2,
m2expr_BuildNegate (location, op3, needconvert),
nBits, needconvert);
m2statement_BuildAssignmentTree (location, op1, res);
m2statement_DeclareLabel (location, labelEndName);
}
}
/* buildUnboundedArrayOf construct an unbounded struct and returns
the gcc tree. The two fields of the structure are initialized to
contentsPtr and high. */
static tree
buildUnboundedArrayOf (tree unbounded, tree contentsPtr, tree high)
{
tree fields = TYPE_FIELDS (unbounded);
tree field_list = NULL_TREE;
tree constructor;
field_list = tree_cons (fields, contentsPtr, field_list);
fields = TREE_CHAIN (fields);
field_list = tree_cons (fields, high, field_list);
constructor = build_constructor_from_list (unbounded, nreverse (field_list));
TREE_CONSTANT (constructor) = 0;
TREE_STATIC (constructor) = 0;
return constructor;
}
/* BuildBinarySetDo if the size of the set is <= TSIZE(WORD) then op1
:= binop(op2, op3) else call m2rtsprocedure(op1, op2, op3). */
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)
{
tree size = m2expr_GetSizeOf (location, settype);
int is_const = FALSE;
int is_left = FALSE;
m2assert_AssertLocation (location);
ASSERT_BOOL (is_op1lvalue);
ASSERT_BOOL (is_op2lvalue);
ASSERT_BOOL (is_op3lvalue);
if (m2expr_CompareTrees (
size, m2decl_BuildIntegerConstant (SET_WORD_SIZE / BITS_PER_UNIT))
<= 0)
/* small set size <= TSIZE(WORD). */
(*binop) (location,
m2treelib_get_rvalue (location, op1, settype, is_op1lvalue),
m2treelib_get_rvalue (location, op2, settype, is_op2lvalue),
m2treelib_get_rvalue (location, op3, settype, is_op3lvalue),
nBits, FALSE);
else
{
tree result;
tree high = m2expr_BuildSub (
location,
m2convert_ToCardinal (
location,
m2expr_BuildDivTrunc (
location, size,
m2expr_GetSizeOf (location, m2type_GetBitsetType ()),
FALSE)),
m2expr_GetCardinalOne (location), FALSE);
/* if op3 is constant then make op3 positive and remember which
direction we are shifting. */
op3 = m2tree_skip_const_decl (op3);
if (TREE_CODE (op3) == INTEGER_CST)
{
is_const = TRUE;
if (tree_int_cst_sgn (op3) < 0)
op3 = m2expr_BuildNegate (location, op3, FALSE);
else
is_left = TRUE;
op3 = m2convert_BuildConvert (location, m2type_GetM2CardinalType (),
op3, FALSE);
}
/* these parameters must match the prototypes of the procedures:
ShiftLeft, ShiftRight, ShiftVal, RotateLeft, RotateRight, RotateVal
inside gm2-iso/SYSTEM.mod. */
/* Remember we must build the parameters in reverse. */
/* parameter 4 amount. */
m2statement_BuildParam (
location,
m2convert_BuildConvert (
location, m2type_GetM2IntegerType (),
m2treelib_get_rvalue (location, op3,
m2tree_skip_type_decl (TREE_TYPE (op3)),
is_op3lvalue),
FALSE));
/* parameter 3 nBits. */
m2statement_BuildParam (
location,
m2convert_BuildConvert (location, m2type_GetM2CardinalType (),
m2expr_FoldAndStrip (nBits), FALSE));
/* parameter 2 destination set. */
m2statement_BuildParam (
location,
buildUnboundedArrayOf (
unbounded,
m2treelib_get_set_address (location, op1, is_op1lvalue), high));
/* parameter 1 source set. */
m2statement_BuildParam (
location,
buildUnboundedArrayOf (
unbounded,
m2treelib_get_set_address (location, op2, is_op2lvalue), high));
/* now call the appropriate procedure inside SYSTEM.mod. */
if (is_const)
if (is_left)
result = m2statement_BuildProcedureCallTree (location, leftproc,
NULL_TREE);
else
result = m2statement_BuildProcedureCallTree (location, rightproc,
NULL_TREE);
else
result = m2statement_BuildProcedureCallTree (location, varproc,
NULL_TREE);
add_stmt (location, result);
}
}
/* Print a warning if a constant expression had overflow in folding.
Invoke this function on every expression that the language requires
to be a constant expression. */
void
m2expr_ConstantExpressionWarning (tree value)
{
if ((TREE_CODE (value) == INTEGER_CST || TREE_CODE (value) == REAL_CST
|| TREE_CODE (value) == FIXED_CST || TREE_CODE (value) == VECTOR_CST
|| TREE_CODE (value) == COMPLEX_CST)
&& TREE_OVERFLOW (value))
pedwarn (input_location, OPT_Woverflow, "overflow in constant expression");
}
/* TreeOverflow return TRUE if the contant expression, t, has caused
an overflow. No error message or warning is emitted and no
modification is made to, t. */
int
m2expr_TreeOverflow (tree t)
{
if ((TREE_CODE (t) == INTEGER_CST
|| (TREE_CODE (t) == COMPLEX_CST
&& TREE_CODE (TREE_REALPART (t)) == INTEGER_CST))
&& TREE_OVERFLOW (t))
return TRUE;
else if ((TREE_CODE (t) == REAL_CST
|| (TREE_CODE (t) == COMPLEX_CST
&& TREE_CODE (TREE_REALPART (t)) == REAL_CST))
&& TREE_OVERFLOW (t))
return TRUE;
else
return FALSE;
}
/* RemoveOverflow if tree, t, is a constant expression it removes any
overflow flag and returns, t. */
tree
m2expr_RemoveOverflow (tree t)
{
if (TREE_CODE (t) == INTEGER_CST
|| (TREE_CODE (t) == COMPLEX_CST
&& TREE_CODE (TREE_REALPART (t)) == INTEGER_CST))
TREE_OVERFLOW (t) = 0;
else if (TREE_CODE (t) == REAL_CST
|| (TREE_CODE (t) == COMPLEX_CST
&& TREE_CODE (TREE_REALPART (t)) == REAL_CST))
TREE_OVERFLOW (t) = 0;
return t;
}
/* BuildCoerce return a tree containing the expression, expr, after
it has been coersed to, type. */
tree
m2expr_BuildCoerce (location_t location, tree des, tree type, tree expr)
{
tree copy = copy_node (expr);
TREE_TYPE (copy) = type;
m2assert_AssertLocation (location);
return m2treelib_build_modify_expr (location, des, NOP_EXPR, copy);
}
/* BuildTrunc return an integer expression from a REAL or LONGREAL op1. */
tree
m2expr_BuildTrunc (tree op1)
{
return convert_to_integer (m2type_GetIntegerType (),
m2expr_FoldAndStrip (op1));
}
/* checkUnaryWholeOverflow decide if we can check this unary expression. */
tree
m2expr_checkUnaryWholeOverflow (location_t location, enum tree_code code,
tree arg, tree lowest, tree min, tree max)
{
if (M2Options_GetWholeValueCheck () && (min != NULL))
{
lowest = m2tree_skip_type_decl (lowest);
arg = fold_convert_loc (location, lowest, arg);
switch (code)
{
case NEGATE_EXPR:
return checkWholeNegateOverflow (location, arg, lowest, min, max);
default:
return NULL;
}
}
return NULL;
}
/* build_unary_op return a unary tree node. */
tree
m2expr_build_unary_op_check (location_t location, enum tree_code code,
tree arg, tree lowest, tree min, tree max)
{
tree argtype = TREE_TYPE (arg);
tree result;
tree check = NULL;
m2assert_AssertLocation (location);
arg = m2expr_FoldAndStrip (arg);
if ((TREE_CODE (argtype) != REAL_TYPE) && (min != NULL))
check = m2expr_checkUnaryWholeOverflow (location, code, arg, lowest, min, max);
result = build1 (code, argtype, arg);
protected_set_expr_location (result, location);
if (check != NULL)
result = build2 (COMPOUND_EXPR, argtype, check, result);
if (TREE_CODE (argtype) == REAL_TYPE)
m2expr_checkRealOverflow (location, code, result);
return m2expr_FoldAndStrip (result);
}
/* build_unary_op return a unary tree node. */
tree
m2expr_build_unary_op (location_t location, enum tree_code code, tree arg,
int flag ATTRIBUTE_UNUSED)
{
tree argtype = TREE_TYPE (arg);
tree result;
m2assert_AssertLocation (location);
arg = m2expr_FoldAndStrip (arg);
result = build1 (code, argtype, arg);
protected_set_expr_location (result, location);
return m2expr_FoldAndStrip (result);
}
/* build_binary_op is a heavily pruned version of the one found in
c-typeck.c. The Modula-2 expression rules are much more restricted
than C. */
tree
build_binary_op (location_t location, enum tree_code code, tree op1, tree op2,
int convert ATTRIBUTE_UNUSED)
{
tree type1 = TREE_TYPE (op1);
tree result;
m2assert_AssertLocation (location);
/* Strip NON_LVALUE_EXPRs, etc., since we aren't using as an lvalue. */
STRIP_TYPE_NOPS (op1);
STRIP_TYPE_NOPS (op2);
op1 = m2expr_FoldAndStrip (op1);
op2 = m2expr_FoldAndStrip (op2);
result = build2 (code, type1, op1, op2);
protected_set_expr_location (result, location);
return m2expr_FoldAndStrip (result);
}
/* BuildLessThanZero - returns a tree containing (< value 0). It
checks the min and max value to ensure that the test can be safely
achieved and will short circuit the result otherwise. */
tree
m2expr_BuildLessThanZero (location_t location, tree value, tree type, tree min,
tree max)
{
if (m2expr_CompareTrees (min, m2expr_GetIntegerZero (location)) >= 0)
/* min is greater than or equal to zero therefore value will always
be >= 0. */
return m2expr_GetIntegerZero (location);
else if (m2expr_CompareTrees (max, m2expr_GetIntegerZero (location)) == -1)
/* max is less than zero therefore value will always be < 0. */
return m2expr_GetIntegerOne (location);
/* we now know 0 lies in the range min..max so we can safely cast
zero to type. */
return m2expr_BuildLessThan (
location, value,
fold_convert_loc (location, type, m2expr_GetIntegerZero (location)));
}
/* BuildGreaterThanZero - returns a tree containing (> value 0). It
checks the min and max value to ensure that the test can be safely
achieved and will short circuit the result otherwise. */
tree
m2expr_BuildGreaterThanZero (location_t location, tree value, tree type,
tree min, tree max)
{
if (m2expr_CompareTrees (min, m2expr_GetIntegerZero (location)) == 1)
/* min is greater than zero therefore value will always be > 0. */
return m2expr_GetIntegerOne (location);
else if (m2expr_CompareTrees (max, m2expr_GetIntegerZero (location)) <= 0)
/* max is less than or equal to zero therefore value will always be
<= 0. */
return m2expr_GetIntegerZero (location);
/* we now know 0 lies in the range min..max so we can safely cast
zero to type. */
return m2expr_BuildGreaterThan (
location, value,
fold_convert_loc (location, type, m2expr_GetIntegerZero (location)));
}
/* BuildEqualToZero - returns a tree containing (= value 0). It
checks the min and max value to ensure that the test can be safely
achieved and will short circuit the result otherwise. */
tree
m2expr_BuildEqualToZero (location_t location, tree value, tree type, tree min,
tree max)
{
if (m2expr_CompareTrees (min, m2expr_GetIntegerZero (location)) == 1)
/* min is greater than zero therefore value will always be > 0. */
return m2expr_GetIntegerZero (location);
else if (m2expr_CompareTrees (max, m2expr_GetIntegerZero (location)) < 0)
/* max is less than or equal to zero therefore value will always be <
0. */
return m2expr_GetIntegerZero (location);
/* we now know 0 lies in the range min..max so we can safely cast
zero to type. */
return m2expr_BuildEqualTo (
location, value,
fold_convert_loc (location, type, m2expr_GetIntegerZero (location)));
}
/* BuildNotEqualToZero - returns a tree containing (# value 0). It
checks the min and max value to ensure that the test can be safely
achieved and will short circuit the result otherwise. */
tree
m2expr_BuildNotEqualToZero (location_t location, tree value, tree type,
tree min, tree max)
{
if (m2expr_CompareTrees (min, m2expr_GetIntegerZero (location)) == 1)
/* min is greater than zero therefore value will always be true. */
return m2expr_GetIntegerOne (location);
else if (m2expr_CompareTrees (max, m2expr_GetIntegerZero (location)) < 0)
/* max is less than or equal to zero therefore value will always be
true. */
return m2expr_GetIntegerOne (location);
/* we now know 0 lies in the range min..max so we can safely cast
zero to type. */
return m2expr_BuildNotEqualTo (
location, value,
fold_convert_loc (location, type, m2expr_GetIntegerZero (location)));
}
/* BuildGreaterThanOrEqualZero - returns a tree containing (>= value 0). It
checks the min and max value to ensure that the test can be safely
achieved and will short circuit the result otherwise. */
tree
m2expr_BuildGreaterThanOrEqualZero (location_t location, tree value, tree type,
tree min, tree max)
{
if (m2expr_CompareTrees (min, m2expr_GetIntegerZero (location)) >= 0)
/* min is greater than or equal to zero therefore value will always be >= 0. */
return m2expr_GetIntegerOne (location);
else if (m2expr_CompareTrees (max, m2expr_GetIntegerZero (location)) < 0)
/* max is less than zero therefore value will always be < 0. */
return m2expr_GetIntegerZero (location);
/* we now know 0 lies in the range min..max so we can safely cast
zero to type. */
return m2expr_BuildGreaterThan (
location, value,
fold_convert_loc (location, type, m2expr_GetIntegerZero (location)));
}
/* BuildLessThanOrEqualZero - returns a tree containing (<= value 0). It
checks the min and max value to ensure that the test can be safely
achieved and will short circuit the result otherwise. */
tree
m2expr_BuildLessThanOrEqualZero (location_t location, tree value, tree type,
tree min, tree max)
{
if (m2expr_CompareTrees (min, m2expr_GetIntegerZero (location)) > 0)
/* min is greater than zero therefore value will always be > 0. */
return m2expr_GetIntegerZero (location);
else if (m2expr_CompareTrees (max, m2expr_GetIntegerZero (location)) <= 0)
/* max is less than or equal to zero therefore value will always be <= 0. */
return m2expr_GetIntegerOne (location);
/* we now know 0 lies in the range min..max so we can safely cast
zero to type. */
return m2expr_BuildLessThanOrEqual (
location, value,
fold_convert_loc (location, type, m2expr_GetIntegerZero (location)));
}
/* get_current_function_name, return the name of the current function if
it currently exists. NULL is returned if we are not inside a function. */
static const char *
get_current_function_name (void)
{
if (current_function_decl != NULL
&& (DECL_NAME (current_function_decl) != NULL)
&& (IDENTIFIER_POINTER (DECL_NAME (current_function_decl)) != NULL))
return IDENTIFIER_POINTER (DECL_NAME (current_function_decl));
return NULL;
}
/* checkWholeNegateOverflow - check to see whether -arg will overflow
an integer.
PROCEDURE sneg (i: INTEGER) ;
BEGIN
IF i = MIN(INTEGER)
THEN
'integer overflow'
END
END sneg ;
general purpose subrange type, i, is currently legal, min is
MIN(type) and max is MAX(type).
PROCEDURE sneg (i: type) ;
BEGIN
max := MAX (type) ;
min := MIN (type) ;
(* cannot overflow if i is 0 *)
IF (i#0) AND
(* will overflow if entire range is positive. *)
((min >= 0) OR
(* will overflow if entire range is negative. *)
(max <= 0) OR
(* c7 and c8 and c9 and c10 -> c17 more units positive. *)
((min < 0) AND (max > 0) AND ((min + max) > 0) AND (i > -min)) OR
(* c11 and c12 and c13 and c14 -> c18 more units negative. *)
((min < 0) AND (max > 0) AND ((min + max) < 0) AND (i < -max)))
THEN
'type overflow'
END
END sneg ; */
static tree
checkWholeNegateOverflow (location_t location,
tree i, tree type, tree min,
tree max)
{
tree a1
= m2expr_BuildNotEqualToZero (location, i, type, min, max); /* i # 0. */
tree c1 = m2expr_BuildGreaterThanZero (location, min, type, min,
max); /* min > 0. */
tree c2 = m2expr_BuildEqualToZero (location, min, type, min,
max); /* min == 0. */
tree c4 = m2expr_BuildLessThanZero (location, max, type, min,
max); /* max < 0. */
tree c5 = m2expr_BuildEqualToZero (location, max, type, min,
max); /* max == 0. */
tree c7 = m2expr_BuildLessThanZero (location, min, type, min,
max); /* min < 0. */
tree c8 = m2expr_BuildGreaterThanZero (location, max, type, min,
max); /* max > 0. */
tree c9 = m2expr_BuildGreaterThanZero (
location, m2expr_BuildAdd (location, min, max, FALSE), type, min,
max); /* min + max > 0. */
tree c10 = m2expr_BuildGreaterThan (
location, i, m2expr_BuildNegate (location, min, FALSE)); /* i > -min. */
tree c11 = m2expr_BuildLessThanZero (
location, m2expr_BuildAdd (location, min, max, FALSE), type, min,
max); /* min + max < 0. */
tree c12 = m2expr_BuildLessThan (
location, i, m2expr_BuildNegate (location, max, FALSE)); /* i < -max. */
tree b1 = m2expr_BuildTruthOrIf (location, c1, c2);
tree b2 = m2expr_BuildTruthOrIf (location, c8, c5);
tree o1 = m2expr_BuildTruthAndIf (location, b1, b2);
tree b3 = m2expr_BuildTruthOrIf (location, c7, c2);
tree b4 = m2expr_BuildTruthOrIf (location, c4, c5);
tree o2 = m2expr_BuildTruthAndIf (location, b3, b4);
tree o3 = m2expr_Build4TruthAndIf (location, c7, c8, c9, c10);
tree o4 = m2expr_Build4TruthAndIf (location, c7, c8, c11, c12);
tree a2 = m2expr_Build4TruthOrIf (location, o1, o2, o3, o4);
tree condition
= m2expr_FoldAndStrip (m2expr_BuildTruthAndIf (location, a1, a2));
tree t = M2Range_BuildIfCallWholeHandlerLoc (location, condition,
get_current_function_name (),
"whole value unary minus will cause range overflow");
return t;
}
/* checkWholeAddOverflow - check to see whether op1 + op2 will
overflow an integer.
PROCEDURE sadd (i, j: INTEGER) ;
BEGIN
IF ((j>0) AND (i > MAX(INTEGER)-j)) OR ((j<0) AND (i < MIN(INTEGER)-j))
THEN
'signed addition overflow'
END
END sadd. */
static tree
checkWholeAddOverflow (location_t location, tree i, tree j, tree lowest,
tree min, tree max)
{
tree j_gt_zero = m2expr_BuildGreaterThanZero (location, j, lowest, min, max);
tree i_gt_max_sub_j = m2expr_BuildGreaterThan (
location, i, m2expr_BuildSub (location, max, j, FALSE));
tree j_lt_zero = m2expr_BuildLessThanZero (location, j, lowest, min, max);
tree i_lt_min_sub_j = m2expr_BuildLessThan (location, i,
m2expr_BuildSub (location, min, j, FALSE));
tree lhs_or = m2expr_FoldAndStrip (m2expr_BuildTruthAndIf (location, j_gt_zero, i_gt_max_sub_j));
tree rhs_or = m2expr_FoldAndStrip (m2expr_BuildTruthAndIf (location, j_lt_zero, i_lt_min_sub_j));
tree condition
= m2expr_FoldAndStrip (m2expr_BuildTruthOrIf (location, lhs_or, rhs_or));
tree result = M2Range_BuildIfCallWholeHandlerLoc (location, condition,
get_current_function_name (),
"whole value addition will cause a range overflow");
return result;
}
/* checkWholeSubOverflow - check to see whether op1 - op2 will
overflow an integer.
PROCEDURE ssub (i, j: INTEGER) ;
BEGIN
IF ((j>0) AND (i < MIN(INTEGER)+j)) OR ((j<0) AND (i > MAX(INTEGER)+j))
THEN
'signed subtraction overflow'
END
END ssub. */
static tree
checkWholeSubOverflow (location_t location, tree i, tree j, tree lowest,
tree min, tree max)
{
tree c1 = m2expr_BuildGreaterThanZero (location, j, lowest, min, max);
tree c2 = m2expr_BuildLessThan (location, i,
m2expr_BuildAdd (location, min, j, FALSE));
tree c3 = m2expr_BuildLessThanZero (location, j, lowest, min, max);
tree c4 = m2expr_BuildGreaterThan (location, i,
m2expr_BuildAdd (location, max, j, FALSE));
tree c5 = m2expr_FoldAndStrip (m2expr_BuildTruthAndIf (location, c1, c2));
tree c6 = m2expr_FoldAndStrip (m2expr_BuildTruthAndIf (location, c3, c4));
tree condition
= m2expr_FoldAndStrip (m2expr_BuildTruthOrIf (location, c5, c6));
tree t = M2Range_BuildIfCallWholeHandlerLoc (location, condition,
get_current_function_name (),
"whole value subtraction will cause a range overflow");
return t;
}
/* Build4TruthAndIf - return TRUE if a && b && c && d. Retain order left to
* right. */
static tree
m2expr_Build4TruthAndIf (location_t location, tree a, tree b, tree c, tree d)
{
tree t1 = m2expr_FoldAndStrip (m2expr_BuildTruthAndIf (location, a, b));
tree t2 = m2expr_FoldAndStrip (m2expr_BuildTruthAndIf (location, t1, c));
return m2expr_FoldAndStrip (m2expr_BuildTruthAndIf (location, t2, d));
}
/* Build3TruthAndIf - return TRUE if a && b && c. Retain order left to right.
*/
static tree
m2expr_Build3TruthAndIf (location_t location, tree op1, tree op2, tree op3)
{
tree t = m2expr_FoldAndStrip (m2expr_BuildTruthAndIf (location, op1, op2));
return m2expr_FoldAndStrip (m2expr_BuildTruthAndIf (location, t, op3));
}
/* Build3TruthOrIf - return TRUE if a || b || c. Retain order left to right.
*/
static tree
m2expr_Build3TruthOrIf (location_t location, tree op1, tree op2, tree op3)
{
tree t = m2expr_FoldAndStrip (m2expr_BuildTruthOrIf (location, op1, op2));
return m2expr_FoldAndStrip (m2expr_BuildTruthOrIf (location, t, op3));
}
/* Build4TruthOrIf - return TRUE if op1 || op2 || op3 || op4. Retain order
left to right. */
static tree
m2expr_Build4TruthOrIf (location_t location, tree op1, tree op2, tree op3,
tree op4)
{
tree t1 = m2expr_FoldAndStrip (m2expr_BuildTruthOrIf (location, op1, op2));
tree t2 = m2expr_FoldAndStrip (m2expr_BuildTruthOrIf (location, t1, op3));
return m2expr_FoldAndStrip (m2expr_BuildTruthOrIf (location, t2, op4));
}
/* Build4LogicalOr - return TRUE if op1 || op2 || op3 || op4. */
static tree
m2expr_Build4LogicalOr (location_t location, tree op1, tree op2, tree op3,
tree op4)
{
tree t1 = m2expr_FoldAndStrip (
m2expr_BuildLogicalOr (location, op1, op2, FALSE));
tree t2
= m2expr_FoldAndStrip (m2expr_BuildLogicalOr (location, t1, op3, FALSE));
return m2expr_FoldAndStrip (
m2expr_BuildLogicalOr (location, t2, op4, FALSE));
}
/* checkWholeMultOverflow - check to see whether i * j will overflow
an integer.
PROCEDURE smult (lhs, rhs: INTEGER) ;
BEGIN
IF ((lhs > 0) AND (rhs > 0) AND (lhs > max DIV rhs)) OR
((lhs > 0) AND (rhs < 0) AND (rhs < min DIV lhs)) OR
((lhs < 0) AND (rhs > 0) AND (lhs < min DIV rhs)) OR
((lhs < 0) AND (rhs < 0) AND (lhs < max DIV rhs))
THEN
error ('signed multiplication overflow')
END
END smult ;
if ((c1 && c3 && c4)
|| (c1 && c5 && c6)
|| (c2 && c3 && c7)
|| (c2 && c5 && c8))
error ('signed subtraction overflow'). */
static tree
testWholeMultOverflow (location_t location, tree lhs, tree rhs,
tree lowest, tree min, tree max)
{
tree c1 = m2expr_BuildGreaterThanZero (location, lhs, lowest, min, max);
tree c2 = m2expr_BuildLessThanZero (location, lhs, lowest, min, max);
tree c3 = m2expr_BuildGreaterThanZero (location, rhs, lowest, min, max);
tree c4 = m2expr_BuildGreaterThan (
location, lhs, m2expr_BuildDivTrunc (location, max, rhs, FALSE));
tree c5 = m2expr_BuildLessThanZero (location, rhs, lowest, min, max);
tree c6 = m2expr_BuildLessThan (
location, rhs, m2expr_BuildDivTrunc (location, min, lhs, FALSE));
tree c7 = m2expr_BuildLessThan (
location, lhs, m2expr_BuildDivTrunc (location, min, rhs, FALSE));
tree c8 = m2expr_BuildLessThan (
location, lhs, m2expr_BuildDivTrunc (location, max, rhs, FALSE));
tree c9 = m2expr_Build3TruthAndIf (location, c1, c3, c4);
tree c10 = m2expr_Build3TruthAndIf (location, c1, c5, c6);
tree c11 = m2expr_Build3TruthAndIf (location, c2, c3, c7);
tree c12 = m2expr_Build3TruthAndIf (location, c2, c5, c8);
tree condition = m2expr_Build4LogicalOr (location, c9, c10, c11, c12);
return condition;
}
static tree
checkWholeMultOverflow (location_t location, tree i, tree j, tree lowest,
tree min, tree max)
{
tree condition = testWholeMultOverflow (location, i, j, lowest, min, max);
tree result = M2Range_BuildIfCallWholeHandlerLoc (location, condition,
get_current_function_name (),
"whole value multiplication will cause a range overflow");
return result;
}
static tree
divMinUnderflow (location_t location, tree value, tree lowest, tree min, tree max)
{
tree min2 = m2expr_BuildMult (location, min, min, FALSE);
tree rhs = m2expr_BuildGreaterThanOrEqual (location, value, min2);
tree lhs = testWholeMultOverflow (location, min, min, lowest, min, max);
return m2expr_BuildTruthAndIf (location, lhs, rhs);
}
/*
divexpr - returns true if a DIV_TRUNC b will overflow.
*/
/* checkWholeDivOverflow - check to see whether i DIV_TRUNC j will overflow
an integer. The Modula-2 implementation of the GCC trees follows:
PROCEDURE divtruncexpr (a, b: INTEGER) : BOOLEAN ;
BEGIN
(* firstly catch division by 0. *)
RETURN ((b = 0) OR
(* case 2 range is always negative. *)
(* in which case a division will be illegal as result will be positive. *)
(max < 0) OR
(* case 1 both min / max are positive, check for underflow. *)
((min >= 0) AND (max >= 0) AND (multMinOverflow (b) OR (a < b * min))) OR
(* case 1 both min / max are positive, check for overflow. *)
((min >= 0) AND (max >= 0) AND (divMinUnderflow (a) OR (b > a DIV min))) OR
(* case 3 mixed range, need to check underflow. *)
((min < 0) AND (max >= 0) AND (a < 0) AND (b < 0) AND (b >= a DIV min)) OR
((min < 0) AND (max >= 0) AND (a < 0) AND (b > 0) AND (b <= a DIV max)) OR
((min < 0) AND (max >= 0) AND (a >= 0) AND (b < 0) AND (a DIV b < min)))
END divtruncexpr ;
s1 -> a DIV min
s2 -> a DIV max
s3 -> a DIV b
b4 -> (min >= 0) AND (max >= 0)
b5 -> (min < 0) AND (max >= 0)
a_lt_b_mult_min -> (a < b * min)
b_mult_min_overflow -> testWholeMultOverflow (location, b, min, lowest, min, max)
b6 -> (b_mult_min_overflow OR a_lt_b_mult_min)
b_gt_s1 -> (b > s1)
a_div_min_overflow -> divMinUnderflow (location, a, min, lowest, min, max)
b7 -> (a_div_min_overflow OR b_gt_s1)
b8 -> (a < 0)
b9 -> (b < 0)
b10 -> (b > 0)
b11 -> (b >= s1)
b12 -> (b <= s2)
b13 -> (s3 < min)
b14 -> a >= 0
c1 -> (b = 0)
c2 -> (max < 0)
c3 -> (b4 AND b6)
c4 -> (b4 AND b7)
c5 -> (b5 AND b8 AND b9 AND b11)
c6 -> (b5 AND b8 AND b10 AND b12)
c7 -> (b5 AND b14 AND b9 AND b13)
if (c1 || c2 || c3 || c4 || c5 || c6 || c7)
error ('signed div trunc overflow'). */
static tree
checkWholeDivTruncOverflow (location_t location, tree i, tree j, tree lowest,
tree min, tree max)
{
tree b4a = m2expr_BuildGreaterThanOrEqualZero (location, min, lowest, min, max);
tree b4b = m2expr_BuildGreaterThanOrEqualZero (location, max, lowest, min, max);
tree b4 = m2expr_BuildTruthAndIf (location, b4a, b4b);
tree b5a = m2expr_BuildLessThanZero (location, min, lowest, min, max);
tree b5 = m2expr_BuildTruthAndIf (location, b5a, b4b);
tree c1 = m2expr_BuildEqualToZero (location, j, lowest, min, max);
tree c2 = m2expr_BuildLessThanZero (location, max, lowest, min, max);
tree i_lt_j_mult_min = m2expr_BuildLessThan (location, i, m2expr_BuildMult (location, j, min, FALSE));
tree j_mult_min_overflow = testWholeMultOverflow (location, j, min, lowest, min, max);
tree b6 = m2expr_BuildTruthOrIf (location, j_mult_min_overflow, i_lt_j_mult_min);
tree c3 = m2expr_BuildTruthAndIf (location, b4, b6);
tree s1 = m2expr_BuildDivTrunc (location, i, min, FALSE);
tree s2 = m2expr_BuildDivTrunc (location, i, max, FALSE);
tree s3 = m2expr_BuildDivTrunc (location, i, j, FALSE);
tree j_gt_s1 = m2expr_BuildGreaterThan (location, j, s1);
tree i_div_min_overflow = divMinUnderflow (location, i, lowest, min, max);
tree b7 = m2expr_BuildTruthOrIf (location, i_div_min_overflow, j_gt_s1);
tree c4 = m2expr_BuildTruthAndIf (location, b4, b7);
tree b8 = m2expr_BuildLessThanZero (location, i, lowest, min, max);
tree b9 = m2expr_BuildLessThanZero (location, j, lowest, min, max);
tree b10 = m2expr_BuildGreaterThanZero (location, j, lowest, min, max);
tree b11 = m2expr_BuildGreaterThanOrEqual (location, j, s1);
tree b12 = m2expr_BuildLessThanOrEqual (location, j, s2);
tree b13 = m2expr_BuildLessThan (location, s3, min);
tree b14 = m2expr_BuildGreaterThanOrEqualZero (location, i, lowest, min, max);
tree c5 = m2expr_Build4TruthAndIf (location, b5, b8, b9, b11);
tree c6 = m2expr_Build4TruthAndIf (location, b5, b8, b10, b12);
tree c7 = m2expr_Build4TruthAndIf (location, b5, b14, b9, b13);
tree c8 = m2expr_Build4TruthOrIf (location, c1, c2, c3, c4);
tree condition = m2expr_Build4TruthOrIf (location, c5, c6, c7, c8);
tree t = M2Range_BuildIfCallWholeHandlerLoc (location, condition,
get_current_function_name (),
"whole value truncated division will cause a range overflow");
return t;
}
#if 0
(*
divexpr - returns true if a DIV_CEIL b will overflow.
*)
(* checkWholeDivCeilOverflow - check to see whether i DIV_CEIL j will overflow
an integer. *)
PROCEDURE divceilexpr (i, j: INTEGER) : BOOLEAN ;
BEGIN
RETURN ((j = 0) OR (* division by zero. *)
(maxT < 0) OR (* both inputs are < 0 and max is < 0,
therefore error. *)
((i # 0) AND (* first operand is legally zero,
result is also legally zero. *)
divCeilOverflowCases (i, j)))
END divceilexpr ;
(*
divCeilOverflowCases - precondition: i, j are in range values.
postcondition: TRUE is returned if i divceil will
result in an overflow/underflow.
*)
PROCEDURE divCeilOverflowCases (i, j: INTEGER) : BOOLEAN ;
BEGIN
RETURN (((i > 0) AND (j > 0) AND divCeilOverflowPosPos (i, j)) OR
((i < 0) AND (j < 0) AND divCeilOverflowNegNeg (i, j)) OR
((i > 0) AND (j < 0) AND divCeilOverflowPosNeg (i, j)) OR
((i < 0) AND (j > 0) AND divCeilOverflowNegPos (i, j)))
END divCeilOverflowCases ;
(*
divCeilOverflowPosPos - precondition: i, j are legal and are both >= 0.
postcondition: TRUE is returned if i divceil will
result in an overflow/underflow.
*)
PROCEDURE divCeilOverflowPosPos (i, j: INTEGER) : BOOLEAN ;
BEGIN
RETURN (((i MOD j = 0) AND (i < j * minT)) OR
(((i MOD j # 0) AND (i < j * minT + 1))))
END divCeilOverflowPosPos ;
(*
divCeilOverflowNegNeg - precondition: i, j are in range values and both < 0.
postcondition: TRUE is returned if i divceil will
result in an overflow/underflow.
*)
PROCEDURE divCeilOverflowNegNeg (i, j: INTEGER) : BOOLEAN ;
BEGIN
RETURN ((maxT <= 0) OR (* signs will cause overflow. *)
(* check for underflow. *)
((ABS (i) MOD ABS (j) = 0) AND (i >= j * minT)) OR
((ABS (i) MOD ABS (j) # 0) AND (i >= j * minT - 1)) OR
(* check for overflow. *)
(((ABS (i) MOD maxT) = 0) AND (ABS (i) DIV maxT > ABS (j))) OR
(((ABS (i) MOD maxT) # 0) AND (ABS (i) DIV maxT > ABS (j) + 1)))
END divCeilOverflowNegNeg ;
(*
divCeilOverflowNegPos - precondition: i, j are in range values. i < 0, j >= 0.
postcondition: TRUE is returned if i divceil will
result in an overflow/underflow.
*)
PROCEDURE divCeilOverflowNegPos (i, j: INTEGER) : BOOLEAN ;
BEGIN
(* easier than might be initially expected. We know minT < 0 and maxT > 0.
We know the result will be negative and therefore we only need to test
against minT. *)
RETURN (((ABS (i) MOD j = 0) AND (i < j * minT)) OR
((ABS (i) MOD j # 0) AND (i < j * minT - 1)))
END divCeilOverflowNegPos ;
(*
divCeilOverflowPosNeg - precondition: i, j are in range values. i >= 0, j < 0.
postcondition: TRUE is returned if i divceil will
result in an overflow/underflow.
*)
PROCEDURE divCeilOverflowPosNeg (i, j: INTEGER) : BOOLEAN ;
BEGIN
(* easier than might be initially expected. We know minT < 0 and maxT > 0.
We know the result will be negative and therefore we only need to test
against minT. *)
RETURN (((i MOD ABS (j) = 0) AND (i > j * minT)) OR
((i MOD ABS (j) # 0) AND (i > j * minT - 1)))
END divCeilOverflowPosNeg ;
#endif
/* divCeilOverflowPosPos, precondition: lhs, rhs are legal and are both >= 0.
Postcondition: TRUE is returned if lhs divceil rhs will result
in an overflow/underflow.
A handbuilt expression of trees implementing:
RETURN (((lhs MOD rhs = 0) AND (min >= 0) AND (lhs < rhs * min)) OR (* check for underflow, no remainder. *)
lhs_lt_rhs_mult_min
(((lhs MOD rhs # 0) AND (lhs < rhs * min + 1)))) (* check for underflow with remainder. *)
((lhs > min) AND (lhs - 1 > rhs * min))
lhs_gt_rhs_mult_min
a -> (lhs MOD rhs = 0) AND (lhs < rhs * min)
b -> (lhs MOD rhs # 0) AND (lhs < rhs * min + 1)
RETURN a OR b. */
static tree
divCeilOverflowPosPos (location_t location, tree i, tree j, tree lowest,
tree min, tree max)
{
tree i_mod_j = m2expr_BuildModTrunc (location, i, j, FALSE);
tree i_mod_j_eq_zero = m2expr_BuildEqualToZero (location, i_mod_j, lowest, min, max);
tree i_mod_j_ne_zero = m2expr_BuildNotEqualToZero (location, i_mod_j, lowest, min, max);
tree j_min = m2expr_BuildMult (location, j, min, FALSE);
tree j_min_1 = m2expr_BuildAdd (location, j_min, m2expr_GetIntegerOne (location), FALSE);
tree i_lt_j_min = m2expr_BuildLessThan (location, i, j_min);
tree i_lt_j_min_1 = m2expr_BuildLessThan (location, i, j_min_1);
tree a = m2expr_BuildTruthAndIf (location, i_mod_j_eq_zero, i_lt_j_min);
tree b = m2expr_BuildTruthAndIf (location, i_mod_j_ne_zero, i_lt_j_min_1);
return m2expr_BuildTruthOrIf (location, a, b);
}
/* divCeilOverflowPosNeg precondition: i, j are in range values and i >=0, j < 0.
Postcondition: TRUE is returned if i divceil j will result in an
overflow/underflow.
A handbuilt expression of trees implementing:
RETURN (((i MOD ABS (j) = 0) AND (i > j * min)) OR
((i MOD ABS (j) # 0) AND (i > j * min - 1)))
abs_j -> (ABS (j))
i_mod_abs_j -> (i MOD abs_j)
i_mod_abs_j_eq_0 -> (i_mod_abs_j = 0)
i_mod_abs_j_ne_0 -> (i_mod_abs_j # 0)
j_mult_min -> (j * min)
j_mult_min_1 -> (j_mult_min - 1)
i_gt_j_mult_min -> (i > j_mult_min)
i_gt_j_mult_min_1 -> (i > j_mult_min_1)
a -> (i_mod_abs_j_eq_0 AND i_gt_j_mult_min)
b -> (i_mod_abs_j_ne_0 AND i_gt_j_mult_min_1)
c -> (a OR b). */
static tree
divCeilOverflowPosNeg (location_t location, tree i, tree j, tree lowest, tree min, tree max)
{
tree abs_j = m2expr_BuildAbs (location, j);
tree i_mod_abs_j = m2expr_BuildModFloor (location, i, abs_j, FALSE);
tree i_mod_abs_j_eq_0 = m2expr_BuildEqualToZero (location, i_mod_abs_j, lowest, min, max);
tree i_mod_abs_j_ne_0 = m2expr_BuildNotEqualToZero (location, i_mod_abs_j, lowest, min, max);
tree j_mult_min = m2expr_BuildMult (location, j, min, FALSE);
tree j_mult_min_1 = m2expr_BuildPostDec (location, j_mult_min);
tree i_gt_j_mult_min = m2expr_BuildGreaterThan (location, i, j_mult_min);
tree i_gt_j_mult_min_1 = m2expr_BuildGreaterThan (location, i, j_mult_min_1);
tree a = m2expr_BuildTruthAndIf (location, i_mod_abs_j_eq_0, i_gt_j_mult_min);
tree b = m2expr_BuildTruthAndIf (location, i_mod_abs_j_ne_0, i_gt_j_mult_min_1);
tree c = m2expr_BuildTruthOrIf (location, a, b);
return c;
}
/* divCeilOverflowNegPos precondition: i, j are in range values and i < 0, j >= 0.
Postcondition: TRUE is returned if i divceil j will result in an
overflow/underflow.
A handbuilt expression of trees implementing:
RETURN (((ABS (i) MOD j = 0) AND (i < j * min)) OR
((ABS (i) MOD j # 0) AND (i < j * min - 1)))
abs_i -> (ABS (i))
abs_i_mod_j -> (abs_i MOD j)
abs_i_mod_j_eq_0 -> (abs_i_mod_j = 0)
abs_i_mod_j_ne_0 -> (abs_i_mod_j # 0)
j_mult_min -> (j * min)
j_mult_min_1 -> (j_mult_min - 1)
i_lt_j_mult_min -> (i < j_mult_min)
i_lt_j_mult_min_1 -> (i < j_mult_min_1)
a = (abs_i_mod_j_eq_0 AND i_lt_j_mult_min)
b = (abs_i_mod_j_ne_0 AND i_lt_j_mult_min_1)
c -> (a OR b). */
static tree
divCeilOverflowNegPos (location_t location, tree i, tree j, tree lowest, tree min, tree max)
{
tree abs_i = m2expr_BuildAbs (location, i);
tree abs_i_mod_j = m2expr_BuildModFloor (location, abs_i, j, FALSE);
tree abs_i_mod_j_eq_0 = m2expr_BuildEqualToZero (location, abs_i_mod_j, lowest, min, max);
tree abs_i_mod_j_ne_0 = m2expr_BuildNotEqualToZero (location, abs_i_mod_j, lowest, min, max);
tree j_mult_min = m2expr_BuildMult (location, j, min, FALSE);
tree j_mult_min_1 = m2expr_BuildPostDec (location, j_mult_min);
tree i_lt_j_mult_min = m2expr_BuildLessThan (location, i, j_mult_min);
tree i_lt_j_mult_min_1 = m2expr_BuildLessThan (location, i, j_mult_min_1);
tree a = m2expr_BuildTruthAndIf (location, abs_i_mod_j_eq_0, i_lt_j_mult_min);
tree b = m2expr_BuildTruthAndIf (location, abs_i_mod_j_ne_0, i_lt_j_mult_min_1);
tree c = m2expr_BuildTruthOrIf (location, a, b);
return c;
}
/* divCeilOverflowNegNeg precondition: i, j are in range values and both < 0.
Postcondition: TRUE is returned if i divceil j will result in an
overflow/underflow.
A handbuilt expression of trees implementing:
RETURN ((max <= 0) OR (* signs will cause overflow. *)
(* check for underflow. *)
((ABS (i) MOD ABS (j) = 0) AND (i >= j * min)) OR
((ABS (i) MOD ABS (j) # 0) AND (i >= j * min - 1)) OR
(* check for overflow. *)
(((ABS (i) MOD max) = 0) AND (ABS (i) DIV max > ABS (j))) OR
(((ABS (i) MOD max) # 0) AND (ABS (i) DIV max > ABS (j) + 1)))
max_lte_0 -> (max <= 0)
abs_i -> (ABS (i))
abs_j -> (ABS (j))
abs_i_mod_abs_j -> (abs_i MOD abs_j)
abs_i_mod_abs_j_eq_0 -> (abs_i_mod_abs_j = 0)
abs_i_mod_abs_j_ne_0 -> (abs_i_mod_abs_j # 0)
j_mult_min -> (j * min)
j_mult_min_1 -> (j_mult_min - 1)
i_ge_j_mult_min -> (i >= j_mult_min)
i_ge_j_mult_min_1 -> (i >= j_mult_min_1)
abs_i_mod_max -> (abs_i mod max)
abs_i_div_max -> (abs_i DIVfloor max)
abs_j_1 -> (abs_j + 1)
abs_i_mod_max_eq_0 -> (abs_i_mod_max = 0)
abs_i_mod_max_ne_0 -> (abs_i_mod_max # 0)
abs_i_div_max_gt_abs_j -> (abs_i_div_max > abs_j)
abs_i_div_max_gt_abs_j_1 -> (abs_i_div_max > abs_j_1)
a -> (abs_i_mod_abs_j_eq_0 AND i_ge_j_mult_min)
b -> (abs_i_mod_abs_j_ne_0 AND i_ge_j_mult_min_1)
c -> (abs_i_mod_max_eq_0 AND abs_i_div_max_gt_abs_j)
d -> (abs_i_mod_max_ne_0 AND abs_i_div_max_gt_abs_j_1)
e -> (a OR b OR c OR d)
return max_lte_0 OR e. */
static tree
divCeilOverflowNegNeg (location_t location, tree i, tree j, tree lowest,
tree min, tree max)
{
tree max_lte_0 = m2expr_BuildLessThanOrEqualZero (location, max, lowest, min, max);
tree abs_i = m2expr_BuildAbs (location, i);
tree abs_j = m2expr_BuildAbs (location, j);
tree abs_i_mod_abs_j = m2expr_BuildModFloor (location, abs_i, abs_j, FALSE);
tree abs_i_mod_abs_j_eq_0 = m2expr_BuildEqualToZero (location, abs_i_mod_abs_j,
lowest, min, max);
tree abs_i_mod_abs_j_ne_0 = m2expr_BuildNotEqualToZero (location, abs_i_mod_abs_j,
lowest, min, max);
tree j_mult_min = m2expr_BuildMult (location, j, min, FALSE);
tree j_mult_min_1 = m2expr_BuildPostDec (location, j_mult_min);
tree i_ge_j_mult_min = m2expr_BuildGreaterThanOrEqual (location, i, j_mult_min);
tree i_ge_j_mult_min_1 = m2expr_BuildGreaterThanOrEqual (location, i, j_mult_min_1);
tree abs_i_mod_max = m2expr_BuildModFloor (location, abs_i, max, FALSE);
tree abs_i_div_max = m2expr_BuildDivFloor (location, abs_i, max, FALSE);
tree abs_j_1 = m2expr_BuildPostInc (location, abs_j);
tree abs_i_mod_max_eq_0 = m2expr_BuildEqualToZero (location, abs_i_mod_max, lowest, min, max);
tree abs_i_mod_max_ne_0 = m2expr_BuildNotEqualToZero (location, abs_i_mod_max, lowest, min, max);
tree abs_i_div_max_gt_abs_j = m2expr_BuildGreaterThan (location, abs_i_div_max, abs_j);
tree abs_i_div_max_gt_abs_j_1 = m2expr_BuildGreaterThan (location, abs_i_div_max, abs_j_1);
tree a = m2expr_BuildTruthAndIf (location, abs_i_mod_abs_j_eq_0, i_ge_j_mult_min);
tree b = m2expr_BuildTruthAndIf (location, abs_i_mod_abs_j_ne_0, i_ge_j_mult_min_1);
tree c = m2expr_BuildTruthAndIf (location, abs_i_mod_max_eq_0, abs_i_div_max_gt_abs_j);
tree d = m2expr_BuildTruthAndIf (location, abs_i_mod_max_ne_0, abs_i_div_max_gt_abs_j_1);
tree e = m2expr_Build4TruthOrIf (location, a, b, c, d);
return m2expr_BuildTruthOrIf (location, max_lte_0, e);
}
/* divCeilOverflowCases, precondition: i, j are in range values.
Postcondition: TRUE is returned if i divceil will result in an
overflow/underflow.
A handbuilt expression of trees implementing:
RETURN (((i > 0) AND (j > 0) AND divCeilOverflowPosPos (i, j)) OR
((i < 0) AND (j < 0) AND divCeilOverflowNegNeg (i, j)) OR
((i > 0) AND (j < 0) AND divCeilOverflowPosNeg (i, j)) OR
((i < 0) AND (j > 0) AND divCeilOverflowNegPos (i, j)))
a -> ((i > 0) AND (j > 0) AND divCeilOverflowPosPos (i, j))
b -> ((i < 0) AND (j < 0) AND divCeilOverflowNegNeg (i, j))
c -> ((i > 0) AND (j < 0) AND divCeilOverflowPosNeg (i, j))
d -> ((i < 0) AND (j > 0) AND divCeilOverflowNegPos (i, j))
RETURN a AND b AND c AND d. */
static tree
divCeilOverflowCases (location_t location, tree i, tree j, tree lowest,
tree min, tree max)
{
tree i_gt_zero = m2expr_BuildGreaterThanZero (location, i, lowest, min, max);
tree j_gt_zero = m2expr_BuildGreaterThanZero (location, j, lowest, min, max);
tree i_lt_zero = m2expr_BuildLessThanZero (location, i, lowest, min, max);
tree j_lt_zero = m2expr_BuildLessThanZero (location, j, lowest, min, max);
tree a = m2expr_Build3TruthAndIf (location, i_gt_zero, j_gt_zero,
divCeilOverflowPosPos (location, i, j, lowest, min, max));
tree b = m2expr_Build3TruthAndIf (location, i_lt_zero, j_lt_zero,
divCeilOverflowNegNeg (location, i, j, lowest, min, max));
tree c = m2expr_Build3TruthAndIf (location, i_gt_zero, j_lt_zero,
divCeilOverflowPosNeg (location, i, j, lowest, min, max));
tree d = m2expr_Build3TruthAndIf (location, i_lt_zero, j_gt_zero,
divCeilOverflowNegPos (location, i, j, lowest, min, max));
return m2expr_Build4TruthOrIf (location, a, b, c, d);
}
/* checkWholeDivCeilOverflow check to see whether i DIV_CEIL j will overflow
an integer. A handbuilt expression of trees implementing:
RETURN ((j = 0) OR (* division by zero. *)
(maxT < 0) OR (* both inputs are < 0 and max is < 0,
therefore error. *)
((i # 0) AND (* first operand is legally zero,
result is also legally zero. *)
divCeilOverflowCases (i, j)))
using the following subexpressions:
j_eq_zero -> (j == 0)
max_lt_zero -> (max < 0)
i_ne_zero -> (i # 0). */
static tree
checkWholeDivCeilOverflow (location_t location, tree i, tree j, tree lowest,
tree min, tree max)
{
tree j_eq_zero = m2expr_BuildEqualToZero (location, j, lowest, min, max);
tree max_lt_zero = m2expr_BuildLessThanZero (location, max, lowest, min, max);
tree i_ne_zero = m2expr_BuildNotEqualToZero (location, i, lowest, min, max);
tree j_lt_zero;
tree rhs = m2expr_BuildTruthAndIf (location,
i_ne_zero,
divCeilOverflowCases (location,
i, j, lowest, min, max));
if (M2Options_GetISO ())
j_lt_zero = m2expr_FoldAndStrip (m2expr_BuildLessThanZero (location, j, lowest, min, max));
else
j_lt_zero = m2expr_GetIntegerZero (location);
j_eq_zero = m2expr_FoldAndStrip (j_eq_zero);
max_lt_zero = m2expr_FoldAndStrip (max_lt_zero);
i_ne_zero = m2expr_FoldAndStrip (i_ne_zero);
rhs = m2expr_FoldAndStrip (rhs);
tree condition = m2expr_Build4TruthOrIf (location, j_eq_zero, max_lt_zero, rhs, j_lt_zero);
tree t = M2Range_BuildIfCallWholeHandlerLoc (location, condition,
get_current_function_name (),
"whole value ceil division will cause a range overflow");
return t;
}
/* checkWholeModTruncOverflow, the GCC tree.def defines TRUNC_MOD_EXPR to return
the remainder which has the same sign as the dividend. In ISO Modula-2 the
divisor must never be negative (or zero). The pseudo code for implementing these
checks is given below:
IF j = 0
THEN
RETURN TRUE (* division by zero. *)
ELSIF j < 0
THEN
RETURN TRUE (* modulus and division by negative (rhs) not allowed in ISO Modula-2. *)
ELSIF i = 0
THEN
RETURN FALSE (* must be legal as result is same as operand. *)
ELSIF i > 0
THEN
(* test for: i MOD j < minT *)
IF j > i
THEN
RETURN FALSE
END ;
RETURN i - ((i DIV j) * j) < minT
ELSIF i < 0
THEN
(* the result will always be positive and less than i, given that j is less than zero
we know that minT must be < 0 as well and therefore the result of i MOD j will
never underflow. *)
RETURN FALSE
END ;
RETURN FALSE
which can be converted into a large expression:
RETURN (j = 0) OR ((j < 0) AND ISO) OR
((i # 0) AND (j <= i) AND (i - ((i DIVtrunc j) * j) < minT)
and into GCC trees:
c1 -> (j = 0)
c2 -> (j < 0) (* only called from ISO or PIM4 or -fpositive-mod-floor *)
c3 -> (i # 0)
c4 -> (j <= i)
c6 -> (i DIVtrunc j)
c7 -> (i - (c6 * j))
c5 -> c7 < minT
t -> (c1 OR c2 OR
(c3 AND c4 AND c5)). */
static tree
checkWholeModTruncOverflow (location_t location, tree i, tree j, tree lowest,
tree min, tree max)
{
tree c1 = m2expr_BuildEqualToZero (location, j, lowest, min, max);
tree c2 = m2expr_BuildLessThanZero (location, j, lowest, min, max);
tree c3 = m2expr_BuildNotEqualToZero (location, i, lowest, min, max);
tree c4 = m2expr_BuildLessThanOrEqual (location, j, i);
tree c6 = m2expr_BuildDivTrunc (location, i, j, FALSE);
tree c7 = m2expr_BuildSub (location, i, m2expr_BuildMult (location, c6, j, FALSE), FALSE);
tree c5 = m2expr_BuildLessThan (location, c7, min);
tree c8 = m2expr_Build3TruthAndIf (location, c3, c4, c5);
tree condition = m2expr_Build3TruthOrIf (location, c1, c2, c8);
tree t = M2Range_BuildIfCallWholeHandlerLoc (location, condition,
get_current_function_name (),
"whole value trunc modulus will cause a range overflow");
return t;
}
/* checkWholeModCeilOverflow, the GCC tree.def defines CEIL_MOD_EXPR to return
the remainder which has the same opposite of the divisor. In gm2 this is
only called when the divisor is negative. The pseudo code for implementing
these checks is given below:
IF j = 0
THEN
RETURN TRUE (* division by zero. *)
END ;
t := i - j * divceil (i, j) ;
printf ("t = %d, i = %d, j = %d, %d / %d = %d\n",
t, i, j, i, j, divceil (i, j));
RETURN NOT ((t >= minT) AND (t <= maxT))
which can be converted into the expression:
t := i - j * divceil (i, j) ;
RETURN (j = 0) OR (NOT ((t >= minT) AND (t <= maxT)))
and into GCC trees:
c1 -> (j = 0)
c2 -> (i - j)
c3 -> (i DIVceil j)
t -> (c2 * c3)
c4 -> (t >= minT)
c5 -> (t <= maxT)
c6 -> (c4 AND c5)
c7 -> (NOT c6)
c8 -> (c1 OR c7)
return c8. */
static tree
checkWholeModCeilOverflow (location_t location,
tree i, tree j, tree lowest,
tree min, tree max)
{
tree c1 = m2expr_BuildEqualToZero (location, j, lowest, min, max);
tree c2 = m2expr_BuildSub (location, i, j, FALSE);
tree c3 = m2expr_BuildDivCeil (location, i, j, FALSE);
tree t = m2expr_BuildMult (location, c2, c3, FALSE);
tree c4 = m2expr_BuildGreaterThanOrEqual (location, t, min);
tree c5 = m2expr_BuildLessThanOrEqual (location, t, max);
tree c6 = m2expr_BuildTruthAndIf (location, c4, c5);
tree c7 = m2expr_BuildTruthNot (location, c6);
tree condition = m2expr_BuildTruthOrIf (location, c1, c7);
tree s = M2Range_BuildIfCallWholeHandlerLoc (location, condition,
get_current_function_name (),
"whole value ceil modulus will cause a range overflow");
return s;
}
/* checkWholeModFloorOverflow, the GCC tree.def defines FLOOR_MOD_EXPR to return
the remainder which has the same sign as the divisor. In gm2 this is
only called when the divisor is positive. The pseudo code for implementing
these checks is given below:
IF j = 0
THEN
RETURN TRUE (* division by zero. *)
END ;
t := i - j * divfloor (i, j) ;
printf ("t = %d, i = %d, j = %d, %d / %d = %d\n",
t, i, j, i, j, divfloor (i, j));
RETURN NOT ((t >= minT) AND (t <= maxT))
which can be converted into the expression:
t := i - j * divfloor (i, j) ;
RETURN (j = 0) OR (NOT ((t >= minT) AND (t <= maxT)))
and into GCC trees:
c1 -> (j = 0)
c2 -> (i - j)
c3 -> (i DIVfloor j)
t -> (c2 * c3)
c4 -> (t >= minT)
c5 -> (t <= maxT)
c6 -> (c4 AND c5)
c7 -> (NOT c6)
c8 -> (c1 OR c7)
return c8. */
static tree
checkWholeModFloorOverflow (location_t location,
tree i, tree j, tree lowest,
tree min, tree max)
{
tree c1 = m2expr_BuildEqualToZero (location, j, lowest, min, max);
tree c2 = m2expr_BuildSub (location, i, j, FALSE);
tree c3 = m2expr_BuildDivFloor (location, i, j, FALSE);
tree t = m2expr_BuildMult (location, c2, c3, FALSE);
tree c4 = m2expr_BuildGreaterThanOrEqual (location, t, min);
tree c5 = m2expr_BuildLessThanOrEqual (location, t, max);
tree c6 = m2expr_BuildTruthAndIf (location, c4, c5);
tree c7 = m2expr_BuildTruthNot (location, c6);
tree condition = m2expr_BuildTruthOrIf (location, c1, c7);
tree s = M2Range_BuildIfCallWholeHandlerLoc (location, condition,
get_current_function_name (),
"whole value floor modulus will cause a range overflow");
return s;
}
#if 0
/* The following is a Modula-2 implementation of the C tree node code
this code has been hand translated into GCC trees. */
(*
divFloorOverflow2 - returns TRUE if an overflow will occur
if i divfloor j is performed.
*)
PROCEDURE divFloorOverflow (i, j: INTEGER) : BOOLEAN ;
BEGIN
RETURN ((j = 0) OR (* division by zero. *)
(maxT < 0) OR (* both inputs are < 0 and max is < 0,
therefore error. *)
(* --fixme-- remember here to also check
if ISO M2 dialect and j < 0
which will also generate an error. *)
((i # 0) AND (* first operand is legally zero,
result is also legally zero. *)
divFloorOverflowCases (i, j)))
END divFloorOverflow ;
(*
divFloorOverflowCases - precondition: i, j are in range values.
postcondition: TRUE is returned if i divfloor will
result in an overflow/underflow.
*)
PROCEDURE divFloorOverflowCases (i, j: INTEGER) : BOOLEAN ;
BEGIN
RETURN (((i > 0) AND (j > 0) AND divFloorOverflowPosPos (i, j)) OR
((i < 0) AND (j < 0) AND divFloorOverflowNegNeg (i, j)) OR
((i > 0) AND (j < 0) AND divFloorOverflowPosNeg (i, j)) OR
((i < 0) AND (j > 0) AND divFloorOverflowNegPos (i, j)))
END divFloorOverflowCases ;
(*
divFloorOverflowPosPos - precondition: lhs, rhs are legal and are both >= 0.
postcondition: TRUE is returned if lhs divfloor rhs will
result in an overflow/underflow.
*)
PROCEDURE divFloorOverflowPosPos (lhs, rhs: INTEGER) : BOOLEAN ;
BEGIN
RETURN multMinOverflow (rhs) OR (lhs < rhs * min)
END divFloorOverflowPosPos ;
(*
divFloorOverflowNegNeg - precondition: i, j are in range values and both < 0.
postcondition: TRUE is returned if i divfloor will
result in an overflow/underflow.
*)
PROCEDURE divFloorOverflowNegNeg (i, j: INTEGER) : BOOLEAN ;
BEGIN
RETURN ((maxT <= 0) OR (* signs will cause overflow. *)
(* check for underflow. *)
(i >= j * minT) OR
(* check for overflow. *)
(ABS (i) DIV maxT > ABS (j)))
END divFloorOverflowNegNeg ;
(*
divFloorOverflowNegPos - precondition: i, j are in range values. i < 0, j >= 0.
postcondition: TRUE is returned if i divfloor will
result in an overflow/underflow.
*)
PROCEDURE divFloorOverflowNegPos (i, j: INTEGER) : BOOLEAN ;
BEGIN
(* easier than might be initially expected. We know minT < 0 and maxT > 0.
We know the result will be negative and therefore we only need to test
against minT. *)
RETURN i < j * minT
END divFloorOverflowNegPos ;
(*
divFloorOverflowPosNeg - precondition: i, j are in range values. i >= 0, j < 0.
postcondition: TRUE is returned if i divfloor will
result in an overflow/underflow.
*)
PROCEDURE divFloorOverflowPosNeg (i, j: INTEGER) : BOOLEAN ;
BEGIN
(* easier than might be initially expected. We know minT < 0 and maxT > 0.
We know the result will be negative and therefore we only need to test
against minT. *)
RETURN i >= j * minT - j (* is safer than i > j * minT -1 *)
END divFloorOverflowPosNeg ;
#endif
/* divFloorOverflowPosPos, precondition: i, j are legal and are both >= 0.
Postcondition: TRUE is returned if i divfloor will result in an overflow/underflow.
A handbuilt expression of trees implementing:
RETURN i < j * min
j_mult_min -> (j * min)
RETURN i < j_mult_min. */
static tree
divFloorOverflowPosPos (location_t location, tree i, tree j, tree min)
{
tree j_mult_min = m2expr_BuildMult (location, j, min, FALSE);
tree i_lt_j_mult_min = m2expr_BuildLessThan (location, i, j_mult_min);
return i_lt_j_mult_min;
}
/* divFloorOverflowNegNeg precondition: i, j are in range values and both < 0.
Postcondition: TRUE is returned if i divfloor j will result in an
overflow/underflow.
A handbuilt expression of trees implementing:
RETURN ((maxT <= 0) OR (* signs will cause overflow. *)
(* check for underflow. *)
(i >= j * min) OR
(* check for overflow. *)
(ABS (i) DIV max > ABS (j)))
max_lte_0 -> (max <= 0)
abs_i -> (ABS (i))
abs_j -> (ABS (j))
j_mult_min -> (j * min)
i_ge_j_mult_min -> (i >= j_mult_min)
abs_i_div_max -> (abs_i divfloor max)
abs_i_div_max_gt_abs_j -> (abs_i_div_max > abs_j)
return max_lte_0 OR
i_ge_j_mult_min OR
abs_i_div_max_gt_abs_j. */
static tree
divFloorOverflowNegNeg (location_t location, tree i, tree j, tree lowest,
tree min, tree max)
{
tree max_lte_0 = m2expr_BuildLessThanOrEqualZero (location, max, lowest, min, max);
tree abs_i = m2expr_BuildAbs (location, i);
tree abs_j = m2expr_BuildAbs (location, j);
tree j_mult_min = m2expr_BuildMult (location, j, min, FALSE);
tree i_ge_j_mult_min = m2expr_BuildGreaterThanOrEqual (location, i, j_mult_min);
tree abs_i_div_max = m2expr_BuildDivFloor (location, abs_i, max, FALSE);
tree abs_i_div_max_gt_abs_j = m2expr_BuildGreaterThan (location, abs_i_div_max, abs_j);
return m2expr_Build3TruthOrIf (location, max_lte_0, i_ge_j_mult_min, abs_i_div_max_gt_abs_j);
}
/* divFloorOverflowPosNeg precondition: i, j are in range values and i >=0, j < 0.
Postcondition: TRUE is returned if i divfloor j will result in an
overflow/underflow.
A handbuilt expression of trees implementing:
RETURN i >= j * min - j (* is safer than i > j * min -1 *)
j_mult_min -> (j * min)
j_mult_min_sub_j -> (j_mult_min - j)
i_ge_j_mult_min_sub_j -> (i >= j_mult_min_sub_j)
return i_ge_j_mult_min_sub_j. */
static tree
divFloorOverflowPosNeg (location_t location, tree i, tree j, tree min)
{
tree j_mult_min = m2expr_BuildMult (location, j, min, FALSE);
tree j_mult_min_sub_j = m2expr_BuildSub (location, j_mult_min, j, FALSE);
tree i_ge_j_mult_min_sub_j = m2expr_BuildGreaterThanOrEqual (location, i, j_mult_min_sub_j);
return i_ge_j_mult_min_sub_j;
}
/* divFloorOverflowNegPos precondition: i, j are in range values and i < 0, j > 0.
Postcondition: TRUE is returned if i divfloor j will result in an
overflow/underflow.
A handbuilt expression of trees implementing:
RETURN i < j * min
j_mult_min -> (j * min)
RETURN i < j_mult_min. */
static tree
divFloorOverflowNegPos (location_t location, tree i, tree j, tree min)
{
tree j_mult_min = m2expr_BuildMult (location, j, min, FALSE);
tree i_lt_j_mult_min = m2expr_BuildLessThan (location, i, j_mult_min);
return i_lt_j_mult_min;
}
/* divFloorOverflowCases, precondition: i, j are in range values.
Postcondition: TRUE is returned if i divfloor will result in an
overflow/underflow.
A handbuilt expression of trees implementing:
RETURN (((i > 0) AND (j > 0) AND divFloorOverflowPosPos (i, j)) OR
((i < 0) AND (j < 0) AND divFloorOverflowNegNeg (i, j)) OR
((i > 0) AND (j < 0) AND divFloorOverflowPosNeg (i, j)) OR
((i < 0) AND (j > 0) AND divFloorOverflowNegPos (i, j)))
a -> ((i > 0) AND (j > 0) AND divFloorOverflowPosPos (i, j))
b -> ((i < 0) AND (j < 0) AND divFloorOverflowNegNeg (i, j))
c -> ((i > 0) AND (j < 0) AND divFloorOverflowPosNeg (i, j))
d -> ((i < 0) AND (j > 0) AND divFloorOverflowNegPos (i, j))
RETURN a AND b AND c AND d. */
static tree
divFloorOverflowCases (location_t location, tree i, tree j, tree lowest,
tree min, tree max)
{
tree i_gt_zero = m2expr_BuildGreaterThanZero (location, i, lowest, min, max);
tree j_gt_zero = m2expr_BuildGreaterThanZero (location, j, lowest, min, max);
tree i_lt_zero = m2expr_BuildLessThanZero (location, i, lowest, min, max);
tree j_lt_zero = m2expr_BuildLessThanZero (location, j, lowest, min, max);
tree a = m2expr_Build3TruthAndIf (location, i_gt_zero, j_gt_zero,
divFloorOverflowPosPos (location, i, j, min));
tree b = m2expr_Build3TruthAndIf (location, i_lt_zero, j_lt_zero,
divFloorOverflowNegNeg (location, i, j, lowest, min, max));
tree c = m2expr_Build3TruthAndIf (location, i_gt_zero, j_lt_zero,
divFloorOverflowPosNeg (location, i, j, min));
tree d = m2expr_Build3TruthAndIf (location, i_lt_zero, j_gt_zero,
divFloorOverflowNegPos (location, i, j, min));
return m2expr_Build4TruthOrIf (location, a, b, c, d);
}
/* checkWholeDivFloorOverflow check to see whether i DIV_FLOOR j will overflow
an integer. A handbuilt expression of trees implementing:
RETURN ((j = 0) OR (* division by zero. *)
(maxT < 0) OR (* both inputs are < 0 and max is < 0,
therefore error. *)
(* we also check
if ISO M2 dialect and j < 0
which will also generate an error. *)
((i # 0) AND (* first operand is legally zero,
result is also legally zero. *)
divFloorOverflowCases (i, j)))
using the following subexpressions:
j_eq_zero -> (j == 0)
max_lt_zero -> (max < 0)
i_ne_zero -> (i # 0). */
static tree
checkWholeDivFloorOverflow (location_t location, tree i, tree j, tree lowest,
tree min, tree max)
{
tree j_eq_zero = m2expr_BuildEqualToZero (location, j, lowest, min, max);
tree max_lt_zero = m2expr_BuildLessThanZero (location, max, lowest, min, max);
tree i_ne_zero = m2expr_BuildNotEqualToZero (location, i, lowest, min, max);
tree j_lt_zero;
tree rhs = m2expr_BuildTruthAndIf (location,
i_ne_zero,
divFloorOverflowCases (location,
i, j, lowest, min, max));
if (M2Options_GetISO ())
/* ISO Modula-2 raises an exception if the right hand operand is < 0. */
j_lt_zero = m2expr_FoldAndStrip (m2expr_BuildLessThanZero (location, j, lowest, min, max));
else
j_lt_zero = m2expr_GetIntegerZero (location);
j_eq_zero = m2expr_FoldAndStrip (j_eq_zero);
max_lt_zero = m2expr_FoldAndStrip (max_lt_zero);
i_ne_zero = m2expr_FoldAndStrip (i_ne_zero);
rhs = m2expr_FoldAndStrip (rhs);
tree condition = m2expr_Build4TruthOrIf (location, j_eq_zero, max_lt_zero, rhs, j_lt_zero);
tree t = M2Range_BuildIfCallWholeHandlerLoc (location, condition,
get_current_function_name (),
"whole value floor division will cause a range overflow");
return t;
}
/* checkWholeOverflow check to see if the binary operators will overflow
ordinal types. */
static tree
m2expr_checkWholeOverflow (location_t location, enum tree_code code, tree op1,
tree op2, tree lowest, tree min, tree max)
{
if (M2Options_GetWholeValueCheck () && (min != NULL))
{
lowest = m2tree_skip_type_decl (lowest);
op1 = fold_convert_loc (location, lowest, op1);
op2 = fold_convert_loc (location, lowest, op2);
switch (code)
{
case PLUS_EXPR:
return checkWholeAddOverflow (location, op1, op2, lowest, min, max);
case MINUS_EXPR:
return checkWholeSubOverflow (location, op1, op2, lowest, min, max);
case MULT_EXPR:
return checkWholeMultOverflow (location, op1, op2, lowest, min, max);
case TRUNC_DIV_EXPR:
return checkWholeDivTruncOverflow (location, op1, op2, lowest, min, max);
case CEIL_DIV_EXPR:
return checkWholeDivCeilOverflow (location, op1, op2, lowest, min, max);
case FLOOR_DIV_EXPR:
return checkWholeDivFloorOverflow (location, op1, op2, lowest, min, max);
case TRUNC_MOD_EXPR:
return checkWholeModTruncOverflow (location, op1, op2, lowest, min, max);
case CEIL_MOD_EXPR:
return checkWholeModCeilOverflow (location, op1, op2, lowest, min, max);
case FLOOR_MOD_EXPR:
return checkWholeModFloorOverflow (location, op1, op2, lowest, min, max);
default:
return NULL;
}
}
return NULL;
}
/* checkRealOverflow if we have enabled real value checking then
generate an overflow check appropriate to the tree code being used. */
static void
m2expr_checkRealOverflow (location_t location, enum tree_code code,
tree result)
{
if (M2Options_GetFloatValueCheck ())
{
tree condition = m2expr_BuildEqualTo (
location, m2builtins_BuiltInIsfinite (location, result),
m2expr_GetIntegerZero (location));
switch (code)
{
case PLUS_EXPR:
m2type_AddStatement (location,
M2Range_BuildIfCallRealHandlerLoc (
location, condition,
get_current_function_name (),
"floating point + has caused an overflow"));
break;
case MINUS_EXPR:
m2type_AddStatement (location,
M2Range_BuildIfCallRealHandlerLoc (
location, condition,
get_current_function_name (),
"floating point - has caused an overflow"));
break;
case RDIV_EXPR:
case FLOOR_DIV_EXPR:
case CEIL_DIV_EXPR:
case TRUNC_DIV_EXPR:
m2type_AddStatement (location,
M2Range_BuildIfCallRealHandlerLoc (
location, condition,
get_current_function_name (),
"floating point / has caused an overflow"));
break;
case MULT_EXPR:
m2type_AddStatement (location,
M2Range_BuildIfCallRealHandlerLoc (
location, condition,
get_current_function_name (),
"floating point * has caused an overflow"));
break;
case NEGATE_EXPR:
m2type_AddStatement (
location, M2Range_BuildIfCallRealHandlerLoc (
location, condition,
get_current_function_name (),
"floating point unary - has caused an overflow"));
default:
break;
}
}
}
/* build_binary_op, a wrapper for the lower level build_binary_op
above. */
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)
{
tree type1, type2, result;
tree check = NULL;
op1 = m2expr_FoldAndStrip (op1);
op2 = m2expr_FoldAndStrip (op2);
type1 = m2tree_skip_type_decl (TREE_TYPE (op1));
type2 = m2tree_skip_type_decl (TREE_TYPE (op2));
m2assert_AssertLocation (location);
if (code == PLUS_EXPR)
{
if (POINTER_TYPE_P (type1))
{
op2 = fold_convert_loc (location, sizetype, unshare_expr (op2));
return fold_build2_loc (location, POINTER_PLUS_EXPR, TREE_TYPE (op1),
op1, op2);
}
else if (POINTER_TYPE_P (type2))
{
op1 = fold_convert_loc (location, sizetype, unshare_expr (op1));
return fold_build2_loc (location, POINTER_PLUS_EXPR, TREE_TYPE (op2),
op2, op1);
}
}
if (code == MINUS_EXPR)
{
if (POINTER_TYPE_P (type1))
{
op2 = fold_convert_loc (location, sizetype, unshare_expr (op2));
op2 = fold_build1_loc (location, NEGATE_EXPR, sizetype, op2);
return fold_build2_loc (location, POINTER_PLUS_EXPR, TREE_TYPE (op1),
op1, op2);
}
else if (POINTER_TYPE_P (type2))
{
op2 = fold_convert_loc (location, sizetype, unshare_expr (op2));
op2 = fold_build1_loc (location, NEGATE_EXPR, sizetype, op2);
op1 = fold_convert_loc (location, sizetype, unshare_expr (op1));
return fold_build2_loc (location, POINTER_PLUS_EXPR, TREE_TYPE (op2),
op2, op1);
}
}
if ((code != LSHIFT_EXPR) && (code != RSHIFT_EXPR) && (code != LROTATE_EXPR)
&& (code == RROTATE_EXPR))
if (type1 != type2)
error_at (location, "not expecting different types to binary operator");
if ((TREE_CODE (type1) != REAL_TYPE) && (min != NULL))
check = m2expr_checkWholeOverflow (location, code, op1, op2, lowest, min, max);
result = build_binary_op (location, code, op1, op2, needconvert);
if (check != NULL)
result = build2 (COMPOUND_EXPR, TREE_TYPE (result), check, result);
if (TREE_CODE (type1) == REAL_TYPE)
m2expr_checkRealOverflow (location, code, result);
return result;
}
/* build_binary_op, a wrapper for the lower level build_binary_op
above. */
tree
m2expr_build_binary_op (location_t location, enum tree_code code, tree op1,
tree op2, int convert)
{
return m2expr_build_binary_op_check (location, code, op1, op2, convert, NULL,
NULL, NULL);
}
/* BuildAddAddress return an expression op1+op2 where op1 is a
pointer type and op2 is not a pointer type. */
tree
m2expr_BuildAddAddress (location_t location, tree op1, tree op2)
{
tree type1, type2;
op1 = m2expr_FoldAndStrip (op1);
op2 = m2expr_FoldAndStrip (op2);
type1 = m2tree_skip_type_decl (TREE_TYPE (op1));
type2 = m2tree_skip_type_decl (TREE_TYPE (op2));
m2assert_AssertLocation (location);
ASSERT_CONDITION (POINTER_TYPE_P (type1));
ASSERT_CONDITION (!POINTER_TYPE_P (type2));
op2 = fold_convert_loc (location, sizetype, unshare_expr (op2));
return fold_build2_loc (location, POINTER_PLUS_EXPR, TREE_TYPE (op1),
m2expr_FoldAndStrip (op1),
m2expr_FoldAndStrip (op2));
}
/* BuildNegateCheck builds a negate tree. */
tree
m2expr_BuildNegateCheck (location_t location, tree arg, tree lowest, tree min,
tree max)
{
tree t;
m2assert_AssertLocation (location);
arg = m2expr_FoldAndStrip (arg);
arg = CheckAddressToCardinal (location, arg);
t = m2expr_build_unary_op_check (location, NEGATE_EXPR, arg, lowest, min,
max);
return m2expr_FoldAndStrip (t);
}
/* BuildNegate build a negate expression and returns the tree. */
tree
m2expr_BuildNegate (location_t location, tree op1, int needconvert)
{
m2assert_AssertLocation (location);
op1 = m2expr_FoldAndStrip (op1);
op1 = CheckAddressToCardinal (location, op1);
return m2expr_build_unary_op (location, NEGATE_EXPR, op1, needconvert);
}
/* BuildSetNegate build a set negate expression and returns the tree. */
tree
m2expr_BuildSetNegate (location_t location, tree op1, int needconvert)
{
m2assert_AssertLocation (location);
return m2expr_build_binary_op (
location, BIT_XOR_EXPR,
m2convert_BuildConvert (location, m2type_GetWordType (),
m2expr_FoldAndStrip (op1), FALSE),
set_full_complement, needconvert);
}
/* BuildMult build a multiplication tree. */
tree
m2expr_BuildMult (location_t location, tree op1, tree op2, int needconvert)
{
op1 = m2expr_FoldAndStrip (op1);
op2 = m2expr_FoldAndStrip (op2);
m2assert_AssertLocation (location);
op1 = CheckAddressToCardinal (location, op1);
op2 = CheckAddressToCardinal (location, op2);
return m2expr_build_binary_op (location, MULT_EXPR, op1, op2, needconvert);
}
/* BuildMultCheck builds a multiplication tree. */
tree
m2expr_BuildMultCheck (location_t location, tree op1, tree op2, tree lowest,
tree min, tree max)
{
tree t;
m2assert_AssertLocation (location);
op1 = m2expr_FoldAndStrip (op1);
op2 = m2expr_FoldAndStrip (op2);
op1 = CheckAddressToCardinal (location, op1);
op2 = CheckAddressToCardinal (location, op2);
t = m2expr_build_binary_op_check (location, MULT_EXPR, op1, op2, FALSE,
lowest, min, max);
return m2expr_FoldAndStrip (t);
}
/* testLimits return the number of bits required to represent:
min..max if it matches the, type. Otherwise NULL_TREE is returned. */
static tree
testLimits (location_t location, tree type, tree min, tree max)
{
m2assert_AssertLocation (location);
if ((m2expr_CompareTrees (TYPE_MAX_VALUE (type), max) == 0)
&& (m2expr_CompareTrees (TYPE_MIN_VALUE (type), min) == 0))
return m2expr_BuildMult (location, m2expr_GetSizeOf (location, type),
m2decl_BuildIntegerConstant (BITS_PER_UNIT),
FALSE);
return NULL_TREE;
}
/* noBitsRequired return the number of bits required to contain, values. */
static tree
noBitsRequired (tree values)
{
int bits = tree_floor_log2 (values);
if (integer_pow2p (values))
return m2decl_BuildIntegerConstant (bits + 1);
else
return m2decl_BuildIntegerConstant (bits + 1);
}
/* getMax return the result of max(a, b). */
static tree
getMax (tree a, tree b)
{
if (m2expr_CompareTrees (a, b) > 0)
return a;
else
return b;
}
/* calcNbits return the smallest number of bits required to
represent: min..max. */
static tree
calcNbits (location_t location, tree min, tree max)
{
int negative = FALSE;
tree t = testLimits (location, m2type_GetIntegerType (), min, max);
m2assert_AssertLocation (location);
if (t == NULL)
t = testLimits (location, m2type_GetCardinalType (), min, max);
if (t == NULL)
{
if (m2expr_CompareTrees (min, m2expr_GetIntegerZero (location)) < 0)
{
min = m2expr_BuildAdd (location, min,
m2expr_GetIntegerOne (location), FALSE);
min = fold (m2expr_BuildNegate (location, min, FALSE));
negative = TRUE;
}
if (m2expr_CompareTrees (max, m2expr_GetIntegerZero (location)) < 0)
{
max = fold (m2expr_BuildNegate (location, max, FALSE));
negative = TRUE;
}
t = noBitsRequired (getMax (min, max));
if (negative)
t = m2expr_BuildAdd (location, t, m2expr_GetIntegerOne (location),
FALSE);
}
return t;
}
/* BuildTBitSize return the minimum number of bits to represent, type. */
tree
m2expr_BuildTBitSize (location_t location, tree type)
{
enum tree_code code = TREE_CODE (type);
tree min;
tree max;
m2assert_AssertLocation (location);
switch (code)
{
case TYPE_DECL:
return m2expr_BuildTBitSize (location, TREE_TYPE (type));
case INTEGER_TYPE:
case ENUMERAL_TYPE:
max = m2convert_BuildConvert (location, m2type_GetIntegerType (),
TYPE_MAX_VALUE (type), FALSE);
min = m2convert_BuildConvert (location, m2type_GetIntegerType (),
TYPE_MIN_VALUE (type), FALSE);
return calcNbits (location, min, max);
case BOOLEAN_TYPE:
return m2expr_GetIntegerOne (location);
default:
return m2expr_BuildMult (location, m2expr_GetSizeOf (location, type),
m2decl_BuildIntegerConstant (BITS_PER_UNIT),
FALSE);
}
}
/* BuildSize build a SIZE function expression and returns the tree. */
tree
m2expr_BuildSize (location_t location, tree op1,
int needconvert ATTRIBUTE_UNUSED)
{
m2assert_AssertLocation (location);
return m2expr_GetSizeOf (location, op1);
}
/* BuildAddr return an expression which calculates the address of op1
and returns the tree. If use_generic is TRUE then create a generic
pointer type. */
tree
m2expr_BuildAddr (location_t location, tree op1, int use_generic)
{
tree type = m2tree_skip_type_decl (TREE_TYPE (op1));
tree ptrType = build_pointer_type (type);
tree result;
m2assert_AssertLocation (location);
if (!gm2_mark_addressable (op1))
error_at (location, "cannot take the address of this expression");
if (use_generic)
result = build1 (ADDR_EXPR, m2type_GetPointerType (), op1);
else
result = build1 (ADDR_EXPR, ptrType, op1);
protected_set_expr_location (result, location);
return result;
}
/* BuildOffset1 build and return an expression containing the number
of bytes the field is offset from the start of the record structure.
This function is the same as the above, except that it derives the
record from the field and then calls BuildOffset. */
tree
m2expr_BuildOffset1 (location_t location, tree field,
int needconvert ATTRIBUTE_UNUSED)
{
m2assert_AssertLocation (location);
return m2expr_BuildOffset (location, DECL_CONTEXT (field), field,
needconvert);
}
/* determinePenultimateField return the field associated with the
DECL_CONTEXT (field) within a record or varient. The record, is a
record/varient but it maybe an outer nested record to the field that
we are searching. Ie:
record = RECORD x: CARDINAL ; y: RECORD field: CARDINAL ; END END ;
determinePenultimateField (record, field) returns, y. We are
assurred that the chain of records leading to field will be unique as
they are built on the fly to implement varient records. */
static tree
determinePenultimateField (tree record, tree field)
{
tree fieldlist = TYPE_FIELDS (record);
tree x, r;
for (x = fieldlist; x; x = TREE_CHAIN (x))
{
if (DECL_CONTEXT (field) == TREE_TYPE (x))
return x;
switch (TREE_CODE (TREE_TYPE (x)))
{
case RECORD_TYPE:
case UNION_TYPE:
r = determinePenultimateField (TREE_TYPE (x), field);
if (r != NULL)
return r;
break;
default:
break;
}
}
return NULL_TREE;
}
/* BuildOffset builds an expression containing the number of bytes
the field is offset from the start of the record structure. The
expression is returned. */
tree
m2expr_BuildOffset (location_t location, tree record, tree field,
int needconvert ATTRIBUTE_UNUSED)
{
m2assert_AssertLocation (location);
if (DECL_CONTEXT (field) == record)
return m2convert_BuildConvert (
location, m2type_GetIntegerType (),
m2expr_BuildAdd (
location, DECL_FIELD_OFFSET (field),
m2expr_BuildDivTrunc (location, DECL_FIELD_BIT_OFFSET (field),
m2decl_BuildIntegerConstant (BITS_PER_UNIT),
FALSE),
FALSE),
FALSE);
else
{
tree r1 = DECL_CONTEXT (field);
tree r2 = determinePenultimateField (record, field);
return m2convert_BuildConvert (
location, m2type_GetIntegerType (),
m2expr_BuildAdd (
location, m2expr_BuildOffset (location, r1, field, needconvert),
m2expr_BuildOffset (location, record, r2, needconvert), FALSE),
FALSE);
}
}
/* BuildLogicalOrAddress build a logical or expressions and return the tree. */
tree
m2expr_BuildLogicalOrAddress (location_t location, tree op1, tree op2,
int needconvert)
{
m2assert_AssertLocation (location);
return m2expr_build_binary_op (location, BIT_IOR_EXPR, op1, op2,
needconvert);
}
/* BuildLogicalOr build a logical or expressions and return the tree. */
tree
m2expr_BuildLogicalOr (location_t location, tree op1, tree op2,
int needconvert)
{
m2assert_AssertLocation (location);
return m2expr_build_binary_op (
location, BIT_IOR_EXPR,
m2convert_BuildConvert (location, m2type_GetWordType (), op1, FALSE),
m2convert_BuildConvert (location, m2type_GetWordType (), op2, FALSE),
needconvert);
}
/* BuildLogicalAnd build a logical and expression and return the tree. */
tree
m2expr_BuildLogicalAnd (location_t location, tree op1, tree op2,
int needconvert)
{
m2assert_AssertLocation (location);
return m2expr_build_binary_op (
location, BIT_AND_EXPR,
m2convert_BuildConvert (location, m2type_GetWordType (), op1, FALSE),
m2convert_BuildConvert (location, m2type_GetWordType (), op2, FALSE),
needconvert);
}
/* BuildSymmetricalDifference build a logical xor expression and return the
* tree. */
tree
m2expr_BuildSymmetricDifference (location_t location, tree op1, tree op2,
int needconvert)
{
m2assert_AssertLocation (location);
return m2expr_build_binary_op (
location, BIT_XOR_EXPR,
m2convert_BuildConvert (location, m2type_GetWordType (), op1, FALSE),
m2convert_BuildConvert (location, m2type_GetWordType (), op2, FALSE),
needconvert);
}
/* BuildLogicalDifference build a logical difference expression and
return the tree. (op1 and (not op2)). */
tree
m2expr_BuildLogicalDifference (location_t location, tree op1, tree op2,
int needconvert)
{
m2assert_AssertLocation (location);
return m2expr_build_binary_op (
location, BIT_AND_EXPR,
m2convert_BuildConvert (location, m2type_GetWordType (), op1, FALSE),
m2expr_BuildSetNegate (location, op2, needconvert), needconvert);
}
/* base_type returns the base type of an ordinal subrange, or the
type itself if it is not a subrange. */
static tree
base_type (tree type)
{
if (type == error_mark_node)
return error_mark_node;
/* Check for ordinal subranges. */
if (m2tree_IsOrdinal (type) && TREE_TYPE (type))
type = TREE_TYPE (type);
return TYPE_MAIN_VARIANT (type);
}
/* boolean_enum_to_unsigned convert a BOOLEAN_TYPE, t, or
ENUMERAL_TYPE to an unsigned type. */
static tree
boolean_enum_to_unsigned (location_t location, tree t)
{
tree type = TREE_TYPE (t);
if (TREE_CODE (base_type (type)) == BOOLEAN_TYPE)
return m2convert_BuildConvert (location, unsigned_type_node, t, FALSE);
else if (TREE_CODE (base_type (type)) == ENUMERAL_TYPE)
return m2convert_BuildConvert (location, unsigned_type_node, t, FALSE);
else
return t;
}
/* check_for_comparison check to see if, op, is of type, badType. If
so then it returns op after it has been cast to, goodType. op will
be an array so we take the address and cast the contents. */
static tree
check_for_comparison (location_t location, tree op, tree badType,
tree goodType)
{
m2assert_AssertLocation (location);
if (m2tree_skip_type_decl (TREE_TYPE (op)) == badType)
/* cannot compare array contents in m2expr_build_binary_op. */
return m2expr_BuildIndirect (
location, m2expr_BuildAddr (location, op, FALSE), goodType);
return op;
}
/* convert_for_comparison return a tree which can be used as an
argument during a comparison. */
static tree
convert_for_comparison (location_t location, tree op)
{
m2assert_AssertLocation (location);
op = boolean_enum_to_unsigned (location, op);
op = check_for_comparison (location, op, m2type_GetISOWordType (),
m2type_GetWordType ());
op = check_for_comparison (location, op, m2type_GetM2Word16 (),
m2type_GetM2Cardinal16 ());
op = check_for_comparison (location, op, m2type_GetM2Word32 (),
m2type_GetM2Cardinal32 ());
op = check_for_comparison (location, op, m2type_GetM2Word64 (),
m2type_GetM2Cardinal64 ());
return op;
}
/* BuildLessThan return a tree which computes <. */
tree
m2expr_BuildLessThan (location_t location, tree op1, tree op2)
{
m2assert_AssertLocation (location);
return m2expr_build_binary_op (
location, LT_EXPR, boolean_enum_to_unsigned (location, op1),
boolean_enum_to_unsigned (location, op2), TRUE);
}
/* BuildGreaterThan return a tree which computes >. */
tree
m2expr_BuildGreaterThan (location_t location, tree op1, tree op2)
{
m2assert_AssertLocation (location);
return m2expr_build_binary_op (
location, GT_EXPR, boolean_enum_to_unsigned (location, op1),
boolean_enum_to_unsigned (location, op2), TRUE);
}
/* BuildLessThanOrEqual return a tree which computes <. */
tree
m2expr_BuildLessThanOrEqual (location_t location, tree op1, tree op2)
{
m2assert_AssertLocation (location);
return m2expr_build_binary_op (
location, LE_EXPR, boolean_enum_to_unsigned (location, op1),
boolean_enum_to_unsigned (location, op2), TRUE);
}
/* BuildGreaterThanOrEqual return a tree which computes >=. */
tree
m2expr_BuildGreaterThanOrEqual (location_t location, tree op1, tree op2)
{
m2assert_AssertLocation (location);
return m2expr_build_binary_op (
location, GE_EXPR, boolean_enum_to_unsigned (location, op1),
boolean_enum_to_unsigned (location, op2), TRUE);
}
/* BuildEqualTo return a tree which computes =. */
tree
m2expr_BuildEqualTo (location_t location, tree op1, tree op2)
{
m2assert_AssertLocation (location);
return m2expr_build_binary_op (location, EQ_EXPR,
convert_for_comparison (location, op1),
convert_for_comparison (location, op2), TRUE);
}
/* BuildEqualNotTo return a tree which computes #. */
tree
m2expr_BuildNotEqualTo (location_t location, tree op1, tree op2)
{
m2assert_AssertLocation (location);
return m2expr_build_binary_op (location, NE_EXPR,
convert_for_comparison (location, op1),
convert_for_comparison (location, op2), TRUE);
}
/* BuildIsSuperset return a tree which computes: op1 & op2 == op2. */
tree
m2expr_BuildIsSuperset (location_t location, tree op1, tree op2)
{
m2assert_AssertLocation (location);
return m2expr_BuildEqualTo (
location, op2, m2expr_BuildLogicalAnd (location, op1, op2, FALSE));
}
/* BuildIsNotSuperset return a tree which computes: op1 & op2 != op2. */
tree
m2expr_BuildIsNotSuperset (location_t location, tree op1, tree op2)
{
m2assert_AssertLocation (location);
return m2expr_BuildNotEqualTo (
location, op2, m2expr_BuildLogicalAnd (location, op1, op2, FALSE));
}
/* BuildIsSubset return a tree which computes: op1 & op2 == op1. */
tree
m2expr_BuildIsSubset (location_t location, tree op1, tree op2)
{
m2assert_AssertLocation (location);
return m2expr_BuildEqualTo (
location, op1, m2expr_BuildLogicalAnd (location, op1, op2, FALSE));
}
/* BuildIsNotSubset return a tree which computes: op1 & op2 != op1. */
tree
m2expr_BuildIsNotSubset (location_t location, tree op1, tree op2)
{
m2assert_AssertLocation (location);
return m2expr_BuildNotEqualTo (
location, op1, m2expr_BuildLogicalAnd (location, op1, op2, FALSE));
}
/* BuildIfConstInVar generates: if constel in varset then goto label. */
void
m2expr_BuildIfConstInVar (location_t location, tree type, tree varset,
tree constel, int is_lvalue, int fieldno,
char *label)
{
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). */
m2treelib_do_jump_if_bit (
location, NE_EXPR,
m2treelib_get_rvalue (location, varset, type, is_lvalue), constel,
label);
else
{
tree fieldlist = TYPE_FIELDS (type);
tree field;
for (field = fieldlist; (field != NULL) && (fieldno > 0);
field = TREE_CHAIN (field))
fieldno--;
m2treelib_do_jump_if_bit (
location, NE_EXPR,
m2treelib_get_set_field_rhs (location, varset, field), constel,
label);
}
}
/* BuildIfConstInVar generates: if not (constel in varset) then goto label. */
void
m2expr_BuildIfNotConstInVar (location_t location, tree type, tree varset,
tree constel, int is_lvalue, int fieldno,
char *label)
{
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). */
m2treelib_do_jump_if_bit (
location, EQ_EXPR,
m2treelib_get_rvalue (location, varset, type, is_lvalue), constel,
label);
else
{
tree fieldlist = TYPE_FIELDS (type);
tree field;
for (field = fieldlist; (field != NULL) && (fieldno > 0);
field = TREE_CHAIN (field))
fieldno--;
m2treelib_do_jump_if_bit (
location, EQ_EXPR,
m2treelib_get_set_field_rhs (location, varset, field), constel,
label);
}
}
/* BuildIfVarInVar generates: if varel in varset then goto label. */
void
m2expr_BuildIfVarInVar (location_t location, tree type, tree varset,
tree varel, int is_lvalue, tree low,
tree high ATTRIBUTE_UNUSED, char *label)
{
tree size = m2expr_GetSizeOf (location, type);
/* calculate the index from the first bit, ie bit 0 represents low value. */
tree index = m2expr_BuildSub (
location, m2convert_BuildConvert (location, m2type_GetIntegerType (),
varel, FALSE),
m2convert_BuildConvert (location, m2type_GetIntegerType (), low, FALSE),
FALSE);
m2assert_AssertLocation (location);
if (m2expr_CompareTrees (
size, m2decl_BuildIntegerConstant (SET_WORD_SIZE / BITS_PER_UNIT))
<= 0)
/* small set size <= TSIZE(WORD). */
m2treelib_do_jump_if_bit (
location, NE_EXPR,
m2treelib_get_rvalue (location, varset, type, is_lvalue), index,
label);
else
{
tree p1 = m2treelib_get_set_address (location, varset, is_lvalue);
/* which word do we need to fetch? */
tree word_index = m2expr_FoldAndStrip (m2expr_BuildDivTrunc (
location, index, m2decl_BuildIntegerConstant (SET_WORD_SIZE),
FALSE));
/* calculate the bit in this word. */
tree offset_into_word = m2expr_FoldAndStrip (m2expr_BuildModTrunc (
location, index, m2decl_BuildIntegerConstant (SET_WORD_SIZE),
FALSE));
tree p2 = m2expr_FoldAndStrip (m2expr_BuildMult (
location, word_index,
m2decl_BuildIntegerConstant (SET_WORD_SIZE / BITS_PER_UNIT), FALSE));
/* calculate the address of the word we are interested in. */
p1 = m2expr_BuildAddAddress (location,
m2convert_convertToPtr (location, p1), p2);
/* fetch the word, extract the bit and test for != 0. */
m2treelib_do_jump_if_bit (
location, NE_EXPR,
m2expr_BuildIndirect (location, p1, m2type_GetBitsetType ()),
offset_into_word, label);
}
}
/* BuildIfNotVarInVar generates: if not (varel in varset) then goto label. */
void
m2expr_BuildIfNotVarInVar (location_t location, tree type, tree varset,
tree varel, int is_lvalue, tree low,
tree high ATTRIBUTE_UNUSED, char *label)
{
tree size = m2expr_GetSizeOf (location, type);
/* calculate the index from the first bit, ie bit 0 represents low value. */
tree index = m2expr_BuildSub (
location, m2convert_BuildConvert (location, m2type_GetIntegerType (),
m2expr_FoldAndStrip (varel), FALSE),
m2convert_BuildConvert (location, m2type_GetIntegerType (),
m2expr_FoldAndStrip (low), FALSE),
FALSE);
index = m2expr_FoldAndStrip (index);
m2assert_AssertLocation (location);
if (m2expr_CompareTrees (
size, m2decl_BuildIntegerConstant (SET_WORD_SIZE / BITS_PER_UNIT))
<= 0)
/* small set size <= TSIZE(WORD). */
m2treelib_do_jump_if_bit (
location, EQ_EXPR,
m2treelib_get_rvalue (location, varset, type, is_lvalue), index,
label);
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_FoldAndStrip (m2expr_BuildDivTrunc (
location, index, m2decl_BuildIntegerConstant (SET_WORD_SIZE),
FALSE));
/* calculate the bit in this word. */
tree offset_into_word = m2expr_FoldAndStrip (m2expr_BuildModTrunc (
location, index, m2decl_BuildIntegerConstant (SET_WORD_SIZE),
FALSE));
tree p2 = m2expr_FoldAndStrip (m2expr_BuildMult (
location, word_index,
m2decl_BuildIntegerConstant (SET_WORD_SIZE / BITS_PER_UNIT), FALSE));
/* calculate the address of the word we are interested in. */
p1 = m2expr_BuildAddAddress (location, p1, p2);
/* fetch the word, extract the bit and test for == 0. */
m2treelib_do_jump_if_bit (
location, EQ_EXPR,
m2expr_BuildIndirect (location, p1, m2type_GetBitsetType ()),
offset_into_word, label);
}
}
/* BuildForeachWordInSetDoIfExpr foreach word in set, type, compute
the expression, expr, and if true goto label. */
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)
{
tree p1 = m2treelib_get_set_address_if_var (location, op1, is_op1lvalue,
is_op1const);
tree p2 = m2treelib_get_set_address_if_var (location, op2, is_op2lvalue,
is_op2const);
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);
m2assert_AssertLocation (location);
ASSERT_CONDITION (TREE_CODE (TREE_TYPE (op1)) == RECORD_TYPE);
ASSERT_CONDITION (TREE_CODE (TREE_TYPE (op2)) == RECORD_TYPE);
while (field1 != NULL && field2 != NULL)
{
m2statement_DoJump (
location,
(*expr) (location,
m2treelib_get_set_value (location, p1, field1, is_op1const,
is_op1lvalue, op1, fieldNo),
m2treelib_get_set_value (location, p2, field2, is_op2const,
is_op2lvalue, op2, fieldNo)),
NULL, label);
fieldNo++;
field1 = m2treelib_get_field_no (type, op1, is_op1const, fieldNo);
field2 = m2treelib_get_field_no (type, op2, is_op2const, fieldNo);
}
}
/* BuildIfInRangeGoto returns a tree containing if var is in the
range low..high then goto label. */
void
m2expr_BuildIfInRangeGoto (location_t location, tree var, tree low, tree high,
char *label)
{
m2assert_AssertLocation (location);
if (m2expr_CompareTrees (low, high) == 0)
m2statement_DoJump (location, m2expr_BuildEqualTo (location, var, low),
NULL, label);
else
m2statement_DoJump (
location,
m2expr_build_binary_op (
location, TRUTH_ANDIF_EXPR,
m2expr_BuildGreaterThanOrEqual (location, var, low),
m2expr_BuildLessThanOrEqual (location, var, high), FALSE),
NULL, label);
}
/* BuildIfNotInRangeGoto returns a tree containing if var is not in
the range low..high then goto label. */
void
m2expr_BuildIfNotInRangeGoto (location_t location, tree var, tree low,
tree high, char *label)
{
m2assert_AssertLocation (location);
if (m2expr_CompareTrees (low, high) == 0)
m2statement_DoJump (location, m2expr_BuildNotEqualTo (location, var, low),
NULL, label);
else
m2statement_DoJump (
location, m2expr_build_binary_op (
location, TRUTH_ORIF_EXPR,
m2expr_BuildLessThan (location, var, low),
m2expr_BuildGreaterThan (location, var, high), FALSE),
NULL, label);
}
/* BuildArray - returns a tree which accesses array[index] given,
lowIndice. */
tree
m2expr_BuildArray (location_t location, tree type, tree array, tree index,
tree low_indice)
{
tree array_type = m2tree_skip_type_decl (TREE_TYPE (array));
tree index_type = TYPE_DOMAIN (array_type);
type = m2tree_skip_type_decl (type);
// ASSERT_CONDITION (low_indice == TYPE_MIN_VALUE (index_type));
low_indice
= m2convert_BuildConvert (location, index_type, low_indice, FALSE);
return build4_loc (location, ARRAY_REF, type, array, index, low_indice,
NULL_TREE);
}
/* BuildComponentRef - build a component reference tree which
accesses record.field. If field does not belong to record it
calls BuildComponentRef on the penultimate field. */
tree
m2expr_BuildComponentRef (location_t location, tree record, tree field)
{
tree recordType = m2tree_skip_reference_type (
m2tree_skip_type_decl (TREE_TYPE (record)));
if (DECL_CONTEXT (field) == recordType)
return build3 (COMPONENT_REF, TREE_TYPE (field), record, field, NULL_TREE);
else
{
tree f = determinePenultimateField (recordType, field);
return m2expr_BuildComponentRef (
location, m2expr_BuildComponentRef (location, record, f), field);
}
}
/* BuildIndirect - build: (*target) given that the object to be
copied is of, type. */
tree
m2expr_BuildIndirect (location_t location ATTRIBUTE_UNUSED, tree target,
tree type)
{
/* Note that the second argument to build1 is:
TYPE_QUALS is a list of modifiers such as const or volatile to apply
to the pointer type, represented as identifiers.
it also determines the type of arithmetic and size of the object to
be indirectly moved. */
tree t1 = m2tree_skip_type_decl (type);
tree t2 = build_pointer_type (t1);
m2assert_AssertLocation (location);
return build1 (INDIRECT_REF, t1,
m2convert_BuildConvert (location, t2, target, FALSE));
}
/* IsTrue - returns TRUE if, t, is known to be TRUE. */
int
m2expr_IsTrue (tree t)
{
return (m2expr_FoldAndStrip (t) == m2type_GetBooleanTrue ());
}
/* IsFalse - returns FALSE if, t, is known to be FALSE. */
int
m2expr_IsFalse (tree t)
{
return (m2expr_FoldAndStrip (t) == m2type_GetBooleanFalse ());
}
/* AreConstantsEqual - maps onto tree.c (tree_int_cst_equal). It
returns TRUE if the value of e1 is the same as e2. */
int
m2expr_AreConstantsEqual (tree e1, tree e2)
{
return tree_int_cst_equal (e1, e2) != 0;
}
/* AreRealOrComplexConstantsEqual - returns TRUE if constants, e1 and
e2 are equal according to IEEE rules. This does not perform bit
equivalence for example IEEE states that -0 == 0 and NaN != NaN. */
int
m2expr_AreRealOrComplexConstantsEqual (tree e1, tree e2)
{
if (TREE_CODE (e1) == COMPLEX_CST)
return (m2expr_AreRealOrComplexConstantsEqual (TREE_REALPART (e1),
TREE_REALPART (e2))
&& m2expr_AreRealOrComplexConstantsEqual (TREE_IMAGPART (e1),
TREE_IMAGPART (e2)));
else
return real_compare (EQ_EXPR, &TREE_REAL_CST (e1), &TREE_REAL_CST (e2));
}
/* DetermineSign, returns -1 if e<0 0 if e==0 1 if e>0
an unsigned constant will never return -1. */
int
m2expr_DetermineSign (tree e)
{
return tree_int_cst_sgn (e);
}
/* Similar to build_int_2 () but allows you to specify the type of
the integer constant that you are creating. */
static tree
build_int_2_type (HOST_WIDE_INT low, HOST_WIDE_INT hi, tree type)
{
tree value;
HOST_WIDE_INT ival[3];
ival[0] = low;
ival[1] = hi;
ival[2] = 0;
widest_int wval = widest_int::from_array (ival, 3);
value = wide_int_to_tree (type, wval);
return value;
}
/* BuildCap - builds the Modula-2 function CAP(t) and returns the
result in a gcc Tree. */
tree
m2expr_BuildCap (location_t location, tree t)
{
tree tt;
tree out_of_range, less_than, greater_than, translated;
m2assert_AssertLocation (location);
t = fold (t);
if (t == error_mark_node)
return error_mark_node;
tt = TREE_TYPE (t);
t = fold (convert (m2type_GetM2CharType (), t));
if (TREE_CODE (tt) == INTEGER_TYPE)
{
less_than = fold (m2expr_build_binary_op (
location, LT_EXPR, t,
build_int_2_type ('a', 0, m2type_GetM2CharType ()), 0));
greater_than = fold (m2expr_build_binary_op (
location, GT_EXPR, t,
build_int_2_type ('z', 0, m2type_GetM2CharType ()), 0));
out_of_range = fold (m2expr_build_binary_op (
location, TRUTH_ORIF_EXPR, less_than, greater_than, 0));
translated = fold (convert (
m2type_GetM2CharType (),
m2expr_build_binary_op (
location, MINUS_EXPR, t,
build_int_2_type ('a' - 'A', 0, m2type_GetM2CharType ()), 0)));
return fold_build3 (COND_EXPR, m2type_GetM2CharType (), out_of_range, t,
translated);
}
error_at (location,
"argument to CAP is not a constant or variable of type CHAR");
return error_mark_node;
}
/* BuildDivM2 if iso or pim4 then build and return ((op2 < 0) : (op1
divceil op2) ? (op1 divfloor op2)) otherwise use divtrunc. */
tree
m2expr_BuildDivM2 (location_t location, tree op1, tree op2,
unsigned int needsconvert)
{
op1 = m2expr_FoldAndStrip (op1);
op2 = m2expr_FoldAndStrip (op2);
ASSERT_CONDITION (TREE_TYPE (op1) == TREE_TYPE (op2));
if (M2Options_GetPIM4 () || M2Options_GetISO ()
|| M2Options_GetPositiveModFloor ())
return fold_build3 (
COND_EXPR, TREE_TYPE (op1),
m2expr_BuildLessThan (
location, op2,
m2convert_BuildConvert (location, TREE_TYPE (op2),
m2expr_GetIntegerZero (location), FALSE)),
m2expr_BuildDivCeil (location, op1, op2, needsconvert),
m2expr_BuildDivFloor (location, op1, op2, needsconvert));
else
return m2expr_BuildDivTrunc (location, op1, op2, needsconvert);
}
/* BuildDivM2Check - build and
return ((op2 < 0) : (op1 divtrunc op2) ? (op1 divfloor op2))
when -fiso, -fpim4 or -fpositive-mod-floor-div is present else
return op1 div trunc op2. Use the checking div equivalents. */
tree
m2expr_BuildDivM2Check (location_t location, tree op1, tree op2,
tree lowest, tree min, tree max)
{
op1 = m2expr_FoldAndStrip (op1);
op2 = m2expr_FoldAndStrip (op2);
ASSERT_CONDITION (TREE_TYPE (op1) == TREE_TYPE (op2));
if (M2Options_GetISO ()
|| M2Options_GetPIM4 () || M2Options_GetPositiveModFloor ())
return fold_build3 (
COND_EXPR, TREE_TYPE (op1),
m2expr_BuildLessThan (
location, op2,
m2convert_BuildConvert (location, TREE_TYPE (op2),
m2expr_GetIntegerZero (location), FALSE)),
m2expr_BuildDivCeilCheck (location, op1, op2, lowest, min, max),
m2expr_BuildDivFloorCheck (location, op1, op2, lowest, min, max));
else
return m2expr_BuildDivTruncCheck (location, op1, op2, lowest, min, max);
}
static
tree
m2expr_BuildISOModM2Check (location_t location,
tree op1, tree op2, tree lowest, tree min, tree max)
{
tree cond = m2expr_BuildLessThan (location, op2,
m2convert_BuildConvert (location, TREE_TYPE (op2),
m2expr_GetIntegerZero (location), FALSE));
/* return the result of the modulus. */
return fold_build3 (COND_EXPR, TREE_TYPE (op1), cond,
/* op2 < 0. */
m2expr_BuildModCeilCheck (location, op1, op2, lowest, min, max),
/* op2 >= 0. */
m2expr_BuildModFloorCheck (location, op1, op2, lowest, min, max));
}
/* BuildModM2Check if iso or pim4 then build and return ((op2 < 0) : (op1
modceil op2) ? (op1 modfloor op2)) otherwise use modtrunc.
Use the checking mod equivalents. */
tree
m2expr_BuildModM2Check (location_t location, tree op1, tree op2,
tree lowest, tree min, tree max)
{
op1 = m2expr_FoldAndStrip (op1);
op2 = m2expr_FoldAndStrip (op2);
ASSERT_CONDITION (TREE_TYPE (op1) == TREE_TYPE (op2));
if (M2Options_GetPIM4 () || M2Options_GetISO ()
|| M2Options_GetPositiveModFloor ())
return m2expr_BuildISOModM2Check (location, op1, op2, lowest, min, max);
else
return m2expr_BuildModTruncCheck (location, op1, op2, lowest, min, max);
}
/* BuildModM2 if iso or pim4 then build and return ((op2 < 0) : (op1
modceil op2) ? (op1 modfloor op2)) otherwise use modtrunc. */
tree
m2expr_BuildModM2 (location_t location, tree op1, tree op2,
unsigned int needsconvert)
{
op1 = m2expr_FoldAndStrip (op1);
op2 = m2expr_FoldAndStrip (op2);
ASSERT_CONDITION (TREE_TYPE (op1) == TREE_TYPE (op2));
if (M2Options_GetPIM4 () || M2Options_GetISO ()
|| M2Options_GetPositiveModFloor ())
return fold_build3 (
COND_EXPR, TREE_TYPE (op1),
m2expr_BuildLessThan (
location, op2,
m2convert_BuildConvert (location, TREE_TYPE (op2),
m2expr_GetIntegerZero (location), FALSE)),
m2expr_BuildModCeil (location, op1, op2, needsconvert),
m2expr_BuildModFloor (location, op1, op2, needsconvert));
else
return m2expr_BuildModTrunc (location, op1, op2, needsconvert);
}
/* BuildAbs build the Modula-2 function ABS(t) and return the result
in a gcc Tree. */
tree
m2expr_BuildAbs (location_t location, tree t)
{
m2assert_AssertLocation (location);
return m2expr_build_unary_op (location, ABS_EXPR, t, 0);
}
/* BuildRe build an expression for the function RE. */
tree
m2expr_BuildRe (tree op1)
{
op1 = m2expr_FoldAndStrip (op1);
if (TREE_CODE (op1) == COMPLEX_CST)
return fold_build1 (REALPART_EXPR, TREE_TYPE (TREE_TYPE (op1)), op1);
else
return build1 (REALPART_EXPR, TREE_TYPE (TREE_TYPE (op1)), op1);
}
/* BuildIm build an expression for the function IM. */
tree
m2expr_BuildIm (tree op1)
{
op1 = m2expr_FoldAndStrip (op1);
if (TREE_CODE (op1) == COMPLEX_CST)
return fold_build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (op1)), op1);
else
return build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (op1)), op1);
}
/* BuildCmplx build an expression for the function CMPLX. */
tree
m2expr_BuildCmplx (location_t location, tree type, tree real, tree imag)
{
tree scalor;
real = m2expr_FoldAndStrip (real);
imag = m2expr_FoldAndStrip (imag);
type = m2tree_skip_type_decl (type);
scalor = TREE_TYPE (type);
if (scalor != TREE_TYPE (real))
real = m2convert_BuildConvert (location, scalor, real, FALSE);
if (scalor != TREE_TYPE (imag))
imag = m2convert_BuildConvert (location, scalor, imag, FALSE);
if ((TREE_CODE (real) == REAL_CST) && (TREE_CODE (imag) == REAL_CST))
return build_complex (type, real, imag);
else
return build2 (COMPLEX_EXPR, type, real, imag);
}
/* BuildBinaryForeachWordDo implements the large set operators. Each
word of the set can be calculated by binop. This function runs along
each word of the large set invoking the binop. */
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)
{
tree size = m2expr_GetSizeOf (location, type);
m2assert_AssertLocation (location);
ASSERT_BOOL (is_op1lvalue);
ASSERT_BOOL (is_op2lvalue);
ASSERT_BOOL (is_op3lvalue);
ASSERT_BOOL (is_op1const);
ASSERT_BOOL (is_op2const);
ASSERT_BOOL (is_op3const);
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),
(*binop) (
location, m2treelib_get_rvalue (location, op2, type, is_op2lvalue),
m2treelib_get_rvalue (location, op3, type, is_op3lvalue), FALSE));
else
{
/* large set size > TSIZE(WORD). */
tree p2 = m2treelib_get_set_address_if_var (location, op2, is_op2lvalue,
is_op2const);
tree p3 = m2treelib_get_set_address_if_var (location, op3, is_op3lvalue,
is_op3const);
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);
tree field3 = m2treelib_get_field_no (type, op3, is_op3const, fieldNo);
if (is_op1const)
error_at (
location,
"internal error: not expecting operand1 to be a constant set");
while (field1 != NULL && field2 != NULL && field3 != NULL)
{
m2statement_BuildAssignmentTree (
location, m2treelib_get_set_field_des (location, op1, field1),
(*binop) (
location,
m2treelib_get_set_value (location, p2, field2, is_op2const,
is_op2lvalue, op2, fieldNo),
m2treelib_get_set_value (location, p3, field3, is_op3const,
is_op3lvalue, op3, fieldNo),
FALSE));
fieldNo++;
field1 = m2treelib_get_field_no (type, op1, is_op1const, fieldNo);
field2 = m2treelib_get_field_no (type, op2, is_op2const, fieldNo);
field3 = m2treelib_get_field_no (type, op3, is_op3const, fieldNo);
}
}
}
/* Append DIGIT to NUM, a number of PRECISION bits being read in base
BASE. */
static int
append_digit (unsigned HOST_WIDE_INT *low, HOST_WIDE_INT *high,
unsigned int digit, unsigned int base)
{
unsigned int shift;
int overflow;
HOST_WIDE_INT add_high, res_high, test_high;
unsigned HOST_WIDE_INT add_low, res_low, test_low;
switch (base)
{
case 2:
shift = 1;
break;
case 8:
shift = 3;
break;
case 10:
shift = 3;
break;
case 16:
shift = 4;
break;
default:
shift = 3;
error ("internal error: not expecting this base value for a constant");
}
/* Multiply by 2, 8 or 16. Catching this overflow here means we
don't need to worry about add_high overflowing. */
if (((*high) >> (INT_TYPE_SIZE - shift)) == 0)
overflow = FALSE;
else
overflow = TRUE;
res_high = *high << shift;
res_low = *low << shift;
res_high |= (*low) >> (INT_TYPE_SIZE - shift);
if (base == 10)
{
add_low = (*low) << 1;
add_high = ((*high) << 1) + ((*low) >> (INT_TYPE_SIZE - 1));
}
else
add_high = add_low = 0;
test_low = add_low + digit;
if (test_low < add_low)
add_high++;
add_low += digit;
test_low = res_low + add_low;
if (test_low < res_low)
add_high++;
test_high = res_high + add_high;
if (test_high < res_high)
overflow = TRUE;
*low = res_low + add_low;
*high = res_high + add_high;
return overflow;
}
/* interpret_integer convert an integer constant into two integer
constants. Heavily borrowed from gcc/cppexp.c. */
int
m2expr_interpret_integer (const char *str, unsigned int base,
unsigned HOST_WIDE_INT *low, HOST_WIDE_INT *high)
{
unsigned const char *p, *end;
int overflow = FALSE;
int len;
*low = 0;
*high = 0;
p = (unsigned const char *)str;
len = strlen (str);
end = p + len;
/* Common case of a single digit. */
if (len == 1)
*low = p[0] - '0';
else
{
unsigned int c = 0;
/* We can add a digit to numbers strictly less than this without
needing the precision and slowness of double integers. */
unsigned HOST_WIDE_INT max = ~(unsigned HOST_WIDE_INT)0;
max = (max - base + 1) / base + 1;
for (; p < end; p++)
{
c = *p;
if (ISDIGIT (c) || (base == 16 && ISXDIGIT (c)))
c = hex_value (c);
else
return overflow;
/* Strict inequality for when max is set to zero. */
if (*low < max)
*low = (*low) * base + c;
else
{
overflow = append_digit (low, high, c, base);
max = 0; /* from now on we always use append_digit. */
}
}
}
return overflow;
}
/* Append DIGIT to NUM, a number of PRECISION bits being read in base
BASE. */
static int
append_m2_digit (unsigned int *low, int *high, unsigned int digit,
unsigned int base)
{
unsigned int shift;
int overflow;
int add_high, res_high, test_high;
unsigned int add_low, res_low, test_low;
switch (base)
{
case 2:
shift = 1;
break;
case 8:
shift = 3;
break;
case 10:
shift = 3;
break;
case 16:
shift = 4;
break;
default:
shift = 3;
error ("internal error: not expecting this base value for a constant");
}
/* Multiply by 2, 8 or 16. Catching this overflow here means we
don't need to worry about add_high overflowing. */
if (((*high) >> (INT_TYPE_SIZE - shift)) == 0)
overflow = FALSE;
else
overflow = TRUE;
res_high = *high << shift;
res_low = *low << shift;
res_high |= (*low) >> (INT_TYPE_SIZE - shift);
if (base == 10)
{
add_low = (*low) << 1;
add_high = ((*high) << 1) + ((*low) >> (INT_TYPE_SIZE - 1));
}
else
add_high = add_low = 0;
test_low = add_low + digit;
if (test_low < add_low)
add_high++;
add_low += digit;
test_low = res_low + add_low;
if (test_low < res_low)
add_high++;
test_high = res_high + add_high;
if (test_high < res_high)
overflow = TRUE;
*low = res_low + add_low;
*high = res_high + add_high;
return overflow;
}
/* interpret_m2_integer convert an integer constant into two integer
constants. Heavily borrowed from gcc/cppexp.c. Note that this is a
copy of the above code except that it uses `int' rather than
HOST_WIDE_INT to allow gm2 to determine what Modula-2 base type to
use for this constant. */
int
m2expr_interpret_m2_integer (const char *str, unsigned int base,
unsigned int *low, int *high)
{
const unsigned char *p, *end;
int overflow = FALSE;
int len;
*low = 0;
*high = 0;
p = (unsigned const char *)str;
len = strlen (str);
end = p + len;
/* Common case of a single digit. */
if (len == 1)
*low = p[0] - '0';
else
{
unsigned int c = 0;
/* We can add a digit to numbers strictly less than this without
needing the precision and slowness of double integers. */
unsigned int max = ~(unsigned int)0;
max = (max - base + 1) / base + 1;
for (; p < end; p++)
{
c = *p;
if (ISDIGIT (c) || (base == 16 && ISXDIGIT (c)))
c = hex_value (c);
else
return overflow;
/* Strict inequality for when max is set to zero. */
if (*low < max)
*low = (*low) * base + c;
else
{
overflow = append_m2_digit (low, high, c, base);
max = 0; /* from now on we always use append_digit. */
}
}
}
return overflow;
}
/* GetSizeOfInBits return the number of bits used to contain, type. */
tree
m2expr_GetSizeOfInBits (tree type)
{
enum tree_code code = TREE_CODE (type);
if (code == FUNCTION_TYPE)
return m2expr_GetSizeOfInBits (ptr_type_node);
if (code == VOID_TYPE)
{
error ("%qs applied to a void type", "sizeof");
return size_one_node;
}
if (code == VAR_DECL)
return m2expr_GetSizeOfInBits (TREE_TYPE (type));
if (code == PARM_DECL)
return m2expr_GetSizeOfInBits (TREE_TYPE (type));
if (code == TYPE_DECL)
return m2expr_GetSizeOfInBits (TREE_TYPE (type));
if (code == COMPONENT_REF)
return m2expr_GetSizeOfInBits (TREE_TYPE (type));
if (code == ERROR_MARK)
return size_one_node;
if (!COMPLETE_TYPE_P (type))
{
error ("%qs applied to an incomplete type", "sizeof");
return size_zero_node;
}
return m2decl_BuildIntegerConstant (TYPE_PRECISION (type));
}
/* GetSizeOf taken from c-typeck.c (c_sizeof). */
tree
m2expr_GetSizeOf (location_t location, tree type)
{
enum tree_code code = TREE_CODE (type);
m2assert_AssertLocation (location);
if (code == FUNCTION_TYPE)
return m2expr_GetSizeOf (location, m2type_GetPointerType ());
if (code == VOID_TYPE)
return size_one_node;
if (code == VAR_DECL)
return m2expr_GetSizeOf (location, TREE_TYPE (type));
if (code == PARM_DECL)
return m2expr_GetSizeOf (location, TREE_TYPE (type));
if (code == TYPE_DECL)
return m2expr_GetSizeOf (location, TREE_TYPE (type));
if (code == ERROR_MARK)
return size_one_node;
if (code == CONSTRUCTOR)
return m2expr_GetSizeOf (location, TREE_TYPE (type));
if (code == FIELD_DECL)
return m2expr_GetSizeOf (location, TREE_TYPE (type));
if (code == COMPONENT_REF)
return m2expr_GetSizeOf (location, TREE_TYPE (type));
if (!COMPLETE_TYPE_P (type))
{
error_at (location, "%qs applied to an incomplete type", "sizeof");
return size_zero_node;
}
/* Convert in case a char is more than one unit. */
return size_binop_loc (
location, CEIL_DIV_EXPR, TYPE_SIZE_UNIT (type),
size_int (TYPE_PRECISION (char_type_node) / BITS_PER_UNIT));
}
tree
m2expr_GetIntegerZero (location_t location ATTRIBUTE_UNUSED)
{
return integer_zero_node;
}
tree
m2expr_GetIntegerOne (location_t location ATTRIBUTE_UNUSED)
{
return integer_one_node;
}
tree
m2expr_GetCardinalOne (location_t location)
{
return m2convert_ToCardinal (location, integer_one_node);
}
tree
m2expr_GetCardinalZero (location_t location)
{
return m2convert_ToCardinal (location, integer_zero_node);
}
tree
m2expr_GetWordZero (location_t location)
{
return m2convert_ToWord (location, integer_zero_node);
}
tree
m2expr_GetWordOne (location_t location)
{
return m2convert_ToWord (location, integer_one_node);
}
tree
m2expr_GetPointerZero (location_t location)
{
return m2convert_convertToPtr (location, integer_zero_node);
}
tree
m2expr_GetPointerOne (location_t location)
{
return m2convert_convertToPtr (location, integer_one_node);
}
/* build_set_full_complement return a word size value with all bits
set to one. */
static tree
build_set_full_complement (location_t location)
{
tree value = integer_zero_node;
int i;
m2assert_AssertLocation (location);
for (i = 0; i < SET_WORD_SIZE; i++)
{
value = m2expr_BuildLogicalOr (
location, value,
m2expr_BuildLSL (
location, m2expr_GetWordOne (location),
m2convert_BuildConvert (location, m2type_GetWordType (),
m2decl_BuildIntegerConstant (i), FALSE),
FALSE),
FALSE);
}
return value;
}
/* init initialise this module. */
void
m2expr_init (location_t location)
{
m2assert_AssertLocation (location);
set_full_complement = build_set_full_complement (location);
}
#include "gt-m2-m2expr.h"
------------------------
New file: gcc/m2/gm2-gcc/m2tree.h
------------------------
/* m2tree.h header file for m2tree.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(m2tree_h)
#define m2tree_h
#if defined(m2tree_c)
#if defined(__GNUG__)
#define EXTERN extern "C"
#else /* !__GNUG__. */
#define EXTERN
#endif /* !__GNUG__. */
#else /* m2tree_c. */
#if defined(__GNUG__)
#define EXTERN extern "C"
#else /* !__GNUG__. */
#define EXTERN extern
#endif /* !__GNUG__. */
#endif /* m2tree_c. */
#include "input.h"
EXTERN int m2tree_is_var (tree var);
EXTERN int m2tree_is_array (tree array);
EXTERN int m2tree_is_type (tree type);
EXTERN tree m2tree_skip_type_decl (tree type);
EXTERN tree m2tree_skip_const_decl (tree exp);
EXTERN int m2tree_IsTreeOverflow (tree value);
EXTERN int m2tree_IsOrdinal (tree type);
EXTERN int m2tree_IsAConstant (tree t);
EXTERN void m2tree_debug_tree (tree t);
EXTERN tree m2tree_skip_reference_type (tree exp);
#ifndef SET_WORD_SIZE
/* gross hack. */
#define SET_WORD_SIZE INT_TYPE_SIZE
#endif /* SET_WORD_SIZE. */
#undef EXTERN
#endif /* m2tree_h. */
------------------------
New file: gcc/m2/gm2-gcc/m2decl.h
------------------------
/* m2decl.h header file for m2decl.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(m2decl_h)
#define m2decl_h
#if defined(m2decl_c)
#if defined(__GNUG__)
#define EXTERN extern "C"
#else /* !__GNUG__. */
#define EXTERN
#endif /* !__GNUG__. */
#else /* !m2decl_c. */
#if defined(__GNUG__)
#define EXTERN extern "C"
#else /* !__GNUG__. */
#define EXTERN extern
#endif /* !__GNUG__. */
#endif /* !m2decl_c. */
EXTERN tree m2decl_GetDeclContext (tree t);
EXTERN tree m2decl_BuildStringConstant (location_t location, const char *string, int length);
EXTERN tree m2decl_BuildCStringConstant (const char *string, int length);
EXTERN tree m2decl_BuildConstLiteralNumber (const char *str,
unsigned int base);
EXTERN void m2decl_DetermineSizeOfConstant (const char *str, unsigned int base,
int *needsLong,
int *needsUnsigned);
EXTERN void m2decl_RememberVariables (tree l);
EXTERN tree m2decl_BuildEndFunctionDeclaration (
location_t location_begin, location_t location_end, const char *name,
tree returntype, int isexternal, int isnested, int ispublic);
EXTERN void m2decl_BuildStartFunctionDeclaration (int uses_varargs);
EXTERN tree m2decl_BuildParameterDeclaration (location_t location, char *name,
tree type, int isreference);
EXTERN tree m2decl_DeclareKnownConstant (location_t location, tree type,
tree value);
EXTERN tree m2decl_DeclareKnownVariable (location_t location, char *name,
tree type, int exported, int imported,
int istemporary, int isglobal,
tree scope);
EXTERN tree m2decl_BuildStringConstantType (int length, const char *string,
tree type);
EXTERN tree m2decl_BuildIntegerConstant (int value);
EXTERN int m2decl_GetBitsPerWord (void);
EXTERN int m2decl_GetBitsPerUnit (void);
EXTERN int m2decl_GetBitsPerInt (void);
EXTERN int m2decl_GetBitsPerBitset (void);
#undef EXTERN
#endif /* m2decl_h. */
------------------------
New file: gcc/m2/gm2-gcc/m2builtins.h
------------------------
/* m2builtins.h header file for m2builtins.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(m2builtins_h)
#define m2builtins_h
#if defined(m2builtins_c)
#if defined(__GNUG__)
#define EXTERN extern "C"
#else /* !__GNUG__. */
#define EXTERN
#endif /* !__GNUG__. */
#else /* !m2builtins_c. */
#if defined(__GNUG__)
#define EXTERN extern "C"
#else /* !__GNUG__. */
#define EXTERN extern
#endif /* !__GNUG__. */
#endif /* !m2builtins_c. */
EXTERN tree m2builtins_GetBuiltinConst (char *name);
EXTERN unsigned int m2builtins_GetBuiltinConstType (char *name);
EXTERN unsigned int m2builtins_GetBuiltinTypeInfoType (const char *ident);
EXTERN tree m2builtins_GetBuiltinTypeInfo (location_t location, tree type,
const char *ident);
EXTERN tree m2builtins_BuiltInMemCopy (location_t location, tree dest,
tree src, tree n);
EXTERN tree m2builtins_BuiltInAlloca (location_t location, tree n);
EXTERN tree m2builtins_BuiltInIsfinite (location_t location, tree e);
EXTERN int m2builtins_BuiltinExists (char *name);
EXTERN tree m2builtins_BuildBuiltinTree (location_t location, char *name);
EXTERN tree m2builtins_BuiltInHugeVal (location_t location);
EXTERN tree m2builtins_BuiltInHugeValShort (location_t location);
EXTERN tree m2builtins_BuiltInHugeValLong (location_t location);
EXTERN void m2builtins_init (location_t location);
#undef EXTERN
#endif /* m2builtins_h. */
------------------------
New file: gcc/m2/gm2-gcc/rtegraph.h
------------------------
/* rtegraph.h runtime exception graph header.
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/>. */
#ifndef RTEGRAPH_H
#define RTEGRAPH_H
struct rtenode;
extern rtenode *rtegraph_init_rtenode (gimple *g, tree fndecl, bool is_func_call);
extern rtenode *rtegraph_lookup (gimple *g, tree fndecl, bool is_call);
extern void rtegraph_candidates_include (rtenode *n);
extern void rtegraph_allnodes_include (rtenode *n);
extern void rtegraph_externs_include (rtenode *n);
extern void rtegraph_constructors_include (rtenode *n);
extern void rtegraph_include_rtscall (rtenode *func);
extern void rtegraph_include_function_call (rtenode *func);
extern void rtegraph_set_current_function (rtenode *func);
extern tree rtegraph_get_func (rtenode *func);
extern void rtegraph_discover (void);
extern void rtegraph_init (void);
extern void rtegraph_finish (void);
#endif /* RTEGRAPH_H. */
------------------------
New file: gcc/m2/gm2-gcc/m2range.h
------------------------
/* m2range.h header file for M2Range.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(m2range_h)
#define m2range_h
#if defined(__GNUG__)
#define EXTERN extern "C"
#else /* !__GNUG__. */
#define EXTERN extern
#endif /* !__GNUG__. */
EXTERN tree M2Range_BuildIfCallWholeHandlerLoc (location_t location,
tree condition,
const char *scope,
const char *message);
EXTERN tree M2Range_BuildIfCallRealHandlerLoc (location_t location,
tree condition,
const char *scope,
const char *message);
#undef EXTERN
#endif /* m2range_h. */
------------------------
New file: gcc/m2/gm2-gcc/m2treelib.h
------------------------
/* m2treelib.h header file for m2treelib.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(m2treelib_h)
#define m2treelib_h
#if defined(m2treelib_c)
#define EXTERN
#else /* !m2treelib_c. */
#define EXTERN extern
#endif /* !m2treelib_c. */
EXTERN void m2treelib_do_jump_if_bit (location_t location, enum tree_code code,
tree word, tree bit, char *label);
EXTERN tree m2treelib_build_modify_expr (location_t location, tree des,
enum tree_code modifycode, tree copy);
EXTERN tree m2treelib_DoCall (location_t location, tree rettype, tree funcptr,
tree param_list);
EXTERN tree m2treelib_DoCall0 (location_t location, tree rettype,
tree funcptr);
EXTERN tree m2treelib_DoCall1 (location_t location, tree rettype, tree funcptr,
tree arg0);
EXTERN tree m2treelib_DoCall2 (location_t location, tree rettype, tree funcptr,
tree arg0, tree arg1);
EXTERN tree m2treelib_DoCall3 (location_t location, tree rettype, tree funcptr,
tree arg0, tree arg1, tree arg2);
EXTERN tree m2treelib_get_rvalue (location_t location, tree t, tree type,
int is_lvalue);
EXTERN tree m2treelib_get_field_no (tree type, tree op, int is_const,
unsigned int fieldNo);
EXTERN tree m2treelib_get_set_value (location_t location, tree p, tree field,
int is_const, int is_lvalue, tree op,
unsigned int fieldNo);
EXTERN tree m2treelib_get_set_address (location_t location, tree op1,
int is_lvalue);
EXTERN tree m2treelib_get_set_field_lhs (location_t location, tree p,
tree field);
EXTERN tree m2treelib_get_set_field_rhs (location_t location, tree p,
tree field);
EXTERN tree m2treelib_get_set_address_if_var (location_t location, tree op,
int is_lvalue, int is_const);
EXTERN tree m2treelib_get_set_field_des (location_t location, tree p,
tree field);
EXTERN tree add_stmt (location_t location, tree t);
EXTERN tree build_stmt (location_t loc, enum tree_code code, ...);
#undef EXTERN
#endif /* m2treelib_h. */
------------------------
New file: gcc/m2/gm2-gcc/m2type.h
------------------------
/* m2type.h header file for m2type.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(m2type_h)
#define m2type_h
#if defined(m2type_c)
#if defined(__GNUG__)
#define EXTERN extern "C"
#else /* !__GNUG__. */
#define EXTERN
#endif /* !__GNUG__. */
#else /* !m2type_c. */
#if defined(__GNUG__)
#define EXTERN extern "C"
#else /* !__GNUG__. */
#define EXTERN extern
#endif /* !__GNUG__. */
#endif /* !m2type_c. */
typedef void *m2type_Constructor;
EXTERN int m2type_ValueInTypeRange (tree type, tree value);
EXTERN int m2type_ExceedsTypeRange (tree type, tree low, tree high);
EXTERN int m2type_ValueOutOfTypeRange (tree type, tree value);
EXTERN int m2type_WithinTypeRange (tree type, tree low, tree high);
EXTERN tree m2type_BuildStartArrayType (tree index_type, tree elt_type,
int type);
EXTERN void m2type_PutArrayType (tree array, tree type);
EXTERN tree m2type_BuildEndArrayType (tree arraytype, tree elementtype,
tree indextype, int type);
EXTERN tree m2type_GetArrayNoOfElements (location_t location, tree arraytype);
EXTERN tree m2type_BuildArrayIndexType (tree low, tree high);
EXTERN void m2type_GarbageCollect (void);
EXTERN void m2type_MarkFunctionReferenced (tree f);
EXTERN void m2type_AddStatement (location_t location, tree t);
EXTERN tree m2type_BuildNumberOfArrayElements (location_t location,
tree arrayType);
EXTERN tree m2type_BuildPackedFieldRecord (location_t location, char *name,
tree fieldtype);
EXTERN tree m2type_SetRecordFieldOffset (tree field, tree byteOffset,
tree bitOffset, tree fieldtype,
tree nbits);
EXTERN tree m2type_SetTypePacked (tree node);
EXTERN tree m2type_SetDeclPacked (tree node);
EXTERN tree m2type_SetAlignment (tree node, tree align);
EXTERN tree m2type_BuildEndRecord (location_t location, tree record,
tree fieldlist, int isPacked);
EXTERN tree m2type_AddStringToTreeList (tree list, tree string);
EXTERN tree m2type_ChainOnParamValue (tree list, tree name, tree str,
tree value);
EXTERN tree m2type_ChainOn (tree t1, tree t2);
EXTERN tree m2type_BuildFieldRecord (location_t location, char *name,
tree type);
EXTERN tree m2type_BuildStartFieldRecord (location_t location, char *name,
tree type);
EXTERN tree m2type_BuildEndFieldVarient (location_t location,
tree varientField, tree varientList,
int isPacked);
EXTERN tree m2type_BuildStartFieldVarient (location_t location, char *name);
EXTERN tree m2type_BuildEndVarient (location_t location, tree varientField,
tree varientList, int isPacked);
EXTERN tree m2type_BuildStartVarient (location_t location, char *name);
EXTERN tree m2type_BuildStartUnion (location_t location, char *name);
EXTERN tree m2type_BuildStartRecord (location_t location, char *name);
EXTERN tree m2type_RealToTree (char *name);
EXTERN tree m2type_BuildArrayStringConstructor (location_t location,
tree arrayType, tree str,
tree length);
#if 0
EXTERN tree m2type_GetPointerOne (void);
EXTERN tree m2type_GetPointerZero (void);
EXTERN tree m2type_GetWordOne (void);
EXTERN tree m2type_GetWordZero (void);
#endif
EXTERN tree m2type_GetM2CharType (void);
EXTERN tree m2type_GetM2IntegerType (void);
EXTERN tree m2type_GetM2ShortRealType (void);
EXTERN tree m2type_GetM2RealType (void);
EXTERN tree m2type_GetM2LongRealType (void);
EXTERN tree m2type_GetM2LongIntType (void);
EXTERN tree m2type_GetM2LongCardType (void);
EXTERN tree m2type_GetM2ShortIntType (void);
EXTERN tree m2type_GetShortIntType (void);
EXTERN tree m2type_GetM2ShortCardType (void);
EXTERN tree m2type_GetShortCardType (void);
EXTERN tree m2type_GetISOWordType (void);
EXTERN tree m2type_GetISOByteType (void);
EXTERN tree m2type_GetISOLocType (void);
EXTERN tree m2type_GetM2Integer8 (void);
EXTERN tree m2type_GetM2Integer16 (void);
EXTERN tree m2type_GetM2Integer32 (void);
EXTERN tree m2type_GetM2Integer64 (void);
EXTERN tree m2type_GetM2Cardinal8 (void);
EXTERN tree m2type_GetM2Cardinal16 (void);
EXTERN tree m2type_GetM2Cardinal32 (void);
EXTERN tree m2type_GetM2Cardinal64 (void);
EXTERN tree m2type_GetM2Word16 (void);
EXTERN tree m2type_GetM2Word32 (void);
EXTERN tree m2type_GetM2Word64 (void);
EXTERN tree m2type_GetM2Bitset8 (void);
EXTERN tree m2type_GetM2Bitset16 (void);
EXTERN tree m2type_GetM2Bitset32 (void);
EXTERN tree m2type_GetM2Real32 (void);
EXTERN tree m2type_GetM2Real64 (void);
EXTERN tree m2type_GetM2Real96 (void);
EXTERN tree m2type_GetM2Real128 (void);
EXTERN tree m2type_GetM2Complex32 (void);
EXTERN tree m2type_GetM2Complex64 (void);
EXTERN tree m2type_GetM2Complex96 (void);
EXTERN tree m2type_GetM2Complex128 (void);
EXTERN tree m2type_GetM2ShortComplexType (void);
EXTERN tree m2type_GetM2LongComplexType (void);
EXTERN tree m2type_GetM2ComplexType (void);
EXTERN tree m2type_GetShortCardType (void);
EXTERN tree m2type_GetProcType (void);
EXTERN tree m2type_GetCSizeTType (void);
EXTERN tree m2type_GetCSSizeTType (void);
EXTERN tree m2type_GetM2CType (void);
EXTERN tree m2type_GetBitsetType (void);
EXTERN tree m2type_GetM2CardinalType (void);
EXTERN tree m2type_GetWordType (void);
EXTERN tree m2type_GetIntegerType (void);
EXTERN tree m2type_GetCardinalType (void);
EXTERN tree m2type_GetPointerType (void);
EXTERN tree m2type_GetLongIntType (void);
EXTERN tree m2type_GetShortRealType (void);
EXTERN tree m2type_GetLongRealType (void);
EXTERN tree m2type_GetRealType (void);
EXTERN tree m2type_GetBitnumType (void);
EXTERN tree m2type_GetVoidType (void);
EXTERN tree m2type_GetByteType (void);
EXTERN tree m2type_GetCharType (void);
EXTERN tree m2type_GetPackedBooleanType (void);
EXTERN tree m2type_GetBooleanTrue (void);
EXTERN tree m2type_GetBooleanFalse (void);
EXTERN tree m2type_GetBooleanType (void);
EXTERN tree m2type_BuildSmallestTypeRange (location_t location, tree low,
tree high);
EXTERN tree m2type_BuildSetTypeFromSubrange (location_t location, char *name,
tree subrangeType, tree lowval,
tree highval, int ispacked);
EXTERN int m2type_GetBitsPerBitset (void);
EXTERN tree m2type_GetM2RType (void);
EXTERN tree m2type_GetM2ZType (void);
EXTERN tree m2type_DeclareKnownType (location_t location, char *name,
tree type);
EXTERN tree m2type_GetTreeType (tree type);
EXTERN tree m2type_BuildEndFunctionType (tree func, tree type,
int uses_varargs);
EXTERN tree m2type_BuildStartFunctionType (
location_t location ATTRIBUTE_UNUSED, char *name ATTRIBUTE_UNUSED);
EXTERN void m2type_InitFunctionTypeParameters (void);
EXTERN tree m2type_BuildVariableArrayAndDeclare (location_t location,
tree elementtype, tree high,
char *name, tree scope);
EXTERN void m2type_InitSystemTypes (location_t location, int loc);
EXTERN void m2type_InitBaseTypes (location_t location);
EXTERN tree m2type_BuildStartType (location_t location, char *name, tree type);
EXTERN tree m2type_BuildEndType (location_t location, tree type);
EXTERN tree m2type_GetDefaultType (location_t location, char *name, tree type);
EXTERN tree m2type_GetMinFrom (location_t location, tree type);
EXTERN tree m2type_GetMaxFrom (location_t location, tree type);
EXTERN void m2type_BuildTypeDeclaration (location_t location, tree type);
EXTERN tree m2type_BuildStartEnumeration (location_t location, char *name,
int ispacked);
EXTERN tree m2type_BuildEndEnumeration (location_t location, tree enumtype,
tree enumvalues);
EXTERN tree m2type_BuildEnumerator (location_t location, char *name,
tree value, tree *enumvalues);
EXTERN tree m2type_BuildPointerType (tree totype);
EXTERN tree m2type_BuildConstPointerType (tree totype);
EXTERN tree m2type_BuildSetType (location_t location, char *name, tree type,
tree lowval, tree highval, int ispacked);
EXTERN void *m2type_BuildStartSetConstructor (tree type);
EXTERN void m2type_BuildSetConstructorElement (void *p, tree value);
EXTERN tree m2type_BuildEndSetConstructor (void *p);
EXTERN void *m2type_BuildStartRecordConstructor (tree type);
EXTERN tree m2type_BuildEndRecordConstructor (void *p);
EXTERN void m2type_BuildRecordConstructorElement (void *p, tree value);
EXTERN void *m2type_BuildStartArrayConstructor (tree type);
EXTERN tree m2type_BuildEndArrayConstructor (void *p);
EXTERN void m2type_BuildArrayConstructorElement (void *p, tree value,
tree indice);
EXTERN tree m2type_BuildCharConstant (location_t location, const char *string);
EXTERN tree m2type_BuildCharConstantChar (location_t location, char ch);
EXTERN tree m2type_BuildSubrangeType (location_t location, char *name,
tree type, tree lowval, tree highval);
EXTERN tree m2type_gm2_unsigned_type (tree type);
EXTERN tree m2type_gm2_signed_type (tree type);
EXTERN tree m2type_gm2_signed_or_unsigned_type (int unsignedp, tree type);
EXTERN tree m2type_gm2_type_for_size (unsigned int bits, int unsignedp);
EXTERN tree m2type_BuildProcTypeParameterDeclaration (location_t location,
tree type,
int isreference);
EXTERN int m2type_IsAddress (tree type);
EXTERN tree m2type_GetCardinalAddressType (void);
#undef EXTERN
#endif /* m2type_h */
------------------------
New file: gcc/m2/gm2-gcc/m2builtins.cc
------------------------
/* m2builtins.cc provides an interface to the GCC builtins.
Copyright (C) 2012-2022 Free Software Foundation, Inc.
Contributed by Gaius Mulley <gaius@glam.ac.uk>.
This file is part of GNU Modula-2.
GNU Modula-2 is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 3, or (at your option)
any later version.
GNU Modula-2 is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
General Public License for more details.
You should have received a copy of the GNU General Public License
along with GNU Modula-2; see the file COPYING3. If not see
<http://www.gnu.org/licenses/>. */
#include "gcc-consolidation.h"
#include "m2block.h"
#include "m2convert.h"
#include "m2decl.h"
#include "m2expr.h"
#include "m2statement.h"
#include "m2tree.h"
#include "m2treelib.h"
#include "m2type.h"
#define GM2
#define GM2_BUG_REPORT \
"Please report this crash to the GNU Modula-2 mailing list " \
"<gm2@nongnu.org>\n"
#define ASSERT(X, Y) \
{ \
if (!(X)) \
{ \
debug_tree (Y); \
internal_error ("%s:%d:assertion of condition `%s' failed", __FILE__, __LINE__, \
#X); \
} \
}
#define ERROR(X) \
{ \
internal_error ("%s:%d:%s", __FILE__, __LINE__, X); \
}
typedef enum {
BT_FN_NONE,
BT_FN_PTR_SIZE,
BT_FN_TRAD_PTR_PTR_CONST_PTR_SIZE,
BT_FN_FLOAT,
BT_FN_DOUBLE,
BT_FN_LONG_DOUBLE,
BT_FN_FLOAT_FLOAT,
BT_FN_DOUBLE_DOUBLE,
BT_FN_LONG_DOUBLE_LONG_DOUBLE,
BT_FN_STRING_CONST_STRING_INT,
BT_FN_INT_CONST_PTR_CONST_PTR_SIZE,
BT_FN_TRAD_PTR_PTR_INT_SIZE,
BT_FN_STRING_STRING_CONST_STRING,
BT_FN_STRING_STRING_CONST_STRING_SIZE,
BT_FN_INT_CONST_STRING_CONST_STRING,
BT_FN_INT_CONST_STRING_CONST_STRING_SIZE,
BT_FN_INT_CONST_STRING,
BT_FN_STRING_CONST_STRING_CONST_STRING,
BT_FN_SIZE_CONST_STRING_CONST_STRING,
BT_FN_PTR_UNSIGNED,
BT_FN_VOID_PTR_INT,
BT_FN_INT_PTR,
BT_FN_INT_FLOAT,
BT_FN_INT_DOUBLE,
BT_FN_INT_LONG_DOUBLE,
BT_FN_FLOAT_FCOMPLEX,
BT_FN_DOUBLE_DCOMPLEX,
BT_FN_LONG_DOUBLE_LDCOMPLEX,
BT_FN_FCOMPLEX_FCOMPLEX,
BT_FN_DCOMPLEX_DCOMPLEX,
BT_FN_LDCOMPLEX_LDCOMPLEX,
BT_FN_DCOMPLEX_DOUBLE_DCOMPLEX,
BT_FN_FCOMPLEX_FLOAT_FCOMPLEX,
BT_FN_LDCOMPLEX_LONG_DOUBLE_LDCOMPLEX,
BT_FN_FLOAT_FLOAT_FLOATPTR,
BT_FN_DOUBLE_DOUBLE_DOUBLEPTR,
BT_FN_LONG_DOUBLE_LONG_DOUBLE_LONG_DOUBLEPTR,
BT_FN_FLOAT_FLOAT_LONG_DOUBLE,
BT_FN_DOUBLE_DOUBLE_LONG_DOUBLE,
BT_FN_LONG_DOUBLE_LONG_DOUBLE_LONG_DOUBLE,
BT_FN_FLOAT_FLOAT_LONG,
BT_FN_DOUBLE_DOUBLE_LONG,
BT_FN_LONG_DOUBLE_LONG_DOUBLE_LONG,
BT_FN_FLOAT_FLOAT_INT,
BT_FN_DOUBLE_DOUBLE_INT,
BT_FN_LONG_DOUBLE_LONG_DOUBLE_INT,
BT_FN_FLOAT_FLOAT_FLOAT,
BT_FN_DOUBLE_DOUBLE_DOUBLE,
} builtin_prototype;
struct builtin_function_entry
{
const char *name;
builtin_prototype defn;
int function_code;
enum built_in_class fclass;
const char *library_name;
tree function_node;
tree return_node;
};
/* entries are added by examining gcc/builtins.def and copying those
functions which can be applied to Modula-2. */
static struct builtin_function_entry list_of_builtins[] = {
{ "__builtin_alloca", BT_FN_PTR_SIZE, BUILT_IN_ALLOCA, BUILT_IN_NORMAL,
"alloca", NULL, NULL },
{ "__builtin_memcpy", BT_FN_TRAD_PTR_PTR_CONST_PTR_SIZE, BUILT_IN_MEMCPY,
BUILT_IN_NORMAL, "memcpy", NULL, NULL },
{ "__builtin_isfinite", BT_FN_INT_DOUBLE, BUILT_IN_ISFINITE, BUILT_IN_NORMAL,
"isfinite", NULL, NULL },
{ "__builtin_sinf", BT_FN_FLOAT_FLOAT, BUILT_IN_SINF, BUILT_IN_NORMAL,
"sinf", NULL, NULL },
{ "__builtin_sin", BT_FN_DOUBLE_DOUBLE, BUILT_IN_SIN, BUILT_IN_NORMAL, "sin",
NULL, NULL },
{ "__builtin_sinl", BT_FN_LONG_DOUBLE_LONG_DOUBLE, BUILT_IN_SINL,
BUILT_IN_NORMAL, "sinl", NULL, NULL },
{ "__builtin_cosf", BT_FN_FLOAT_FLOAT, BUILT_IN_SINF, BUILT_IN_NORMAL,
"cosf", NULL, NULL },
{ "__builtin_cos", BT_FN_DOUBLE_DOUBLE, BUILT_IN_COS, BUILT_IN_NORMAL, "cos",
NULL, NULL },
{ "__builtin_cosl", BT_FN_LONG_DOUBLE_LONG_DOUBLE, BUILT_IN_COSL,
BUILT_IN_NORMAL, "cosl", NULL, NULL },
{ "__builtin_sqrtf", BT_FN_FLOAT_FLOAT, BUILT_IN_SQRTF, BUILT_IN_NORMAL,
"sqrtf", NULL, NULL },
{ "__builtin_sqrt", BT_FN_DOUBLE_DOUBLE, BUILT_IN_SQRT, BUILT_IN_NORMAL,
"sqrt", NULL, NULL },
{ "__builtin_sqrtl", BT_FN_LONG_DOUBLE_LONG_DOUBLE, BUILT_IN_SQRTL,
BUILT_IN_NORMAL, "sqrtl", NULL, NULL },
{ "__builtin_fabsf", BT_FN_FLOAT_FLOAT, BUILT_IN_FABSF, BUILT_IN_NORMAL,
"fabsf", NULL, NULL },
{ "__builtin_fabs", BT_FN_DOUBLE_DOUBLE, BUILT_IN_FABS, BUILT_IN_NORMAL,
"fabs", NULL, NULL },
{ "__builtin_fabsl", BT_FN_LONG_DOUBLE_LONG_DOUBLE, BUILT_IN_FABSL,
BUILT_IN_NORMAL, "fabsl", NULL, NULL },
{ "__builtin_logf", BT_FN_FLOAT_FLOAT, BUILT_IN_LOGF, BUILT_IN_NORMAL,
"logf", NULL, NULL },
{ "__builtin_log", BT_FN_DOUBLE_DOUBLE, BUILT_IN_LOG, BUILT_IN_NORMAL, "log",
NULL, NULL },
{ "__builtin_logl", BT_FN_LONG_DOUBLE_LONG_DOUBLE, BUILT_IN_LOGL,
BUILT_IN_NORMAL, "logl", NULL, NULL },
{ "__builtin_expf", BT_FN_FLOAT_FLOAT, BUILT_IN_EXPF, BUILT_IN_NORMAL,
"expf", NULL, NULL },
{ "__builtin_exp", BT_FN_DOUBLE_DOUBLE, BUILT_IN_EXP, BUILT_IN_NORMAL, "exp",
NULL, NULL },
{ "__builtin_expl", BT_FN_LONG_DOUBLE_LONG_DOUBLE, BUILT_IN_EXPL,
BUILT_IN_NORMAL, "expl", NULL, NULL },
{ "__builtin_log10f", BT_FN_FLOAT_FLOAT, BUILT_IN_LOG10F, BUILT_IN_NORMAL,
"log10f", NULL, NULL },
{ "__builtin_log10", BT_FN_DOUBLE_DOUBLE, BUILT_IN_LOG10, BUILT_IN_NORMAL,
"log10", NULL, NULL },
{ "__builtin_log10l", BT_FN_LONG_DOUBLE_LONG_DOUBLE, BUILT_IN_LOG10L,
BUILT_IN_NORMAL, "log10l", NULL, NULL },
{ "__builtin_ilogbf", BT_FN_INT_FLOAT, BUILT_IN_ILOGBF, BUILT_IN_NORMAL,
"ilogbf", NULL, NULL },
{ "__builtin_ilogb", BT_FN_INT_DOUBLE, BUILT_IN_ILOGB, BUILT_IN_NORMAL,
"ilogb", NULL, NULL },
{ "__builtin_ilogbl", BT_FN_INT_LONG_DOUBLE, BUILT_IN_ILOGBL,
BUILT_IN_NORMAL, "ilogbl", NULL, NULL },
{ "__builtin_atan2f", BT_FN_FLOAT_FLOAT_FLOAT, BUILT_IN_ATAN2F,
BUILT_IN_NORMAL, "atan2f", NULL, NULL },
{ "__builtin_atan2", BT_FN_DOUBLE_DOUBLE_DOUBLE, BUILT_IN_ATAN2,
BUILT_IN_NORMAL, "atan2", NULL, NULL },
{ "__builtin_atan2l", BT_FN_LONG_DOUBLE_LONG_DOUBLE_LONG_DOUBLE,
BUILT_IN_ATAN2L, BUILT_IN_NORMAL, "atan2l", NULL, NULL },
{ "__builtin_signbit", BT_FN_INT_DOUBLE, BUILT_IN_SIGNBIT, BUILT_IN_NORMAL,
"signbit", NULL, NULL },
{ "__builtin_signbitf", BT_FN_INT_FLOAT, BUILT_IN_SIGNBITF, BUILT_IN_NORMAL,
"signbitf", NULL, NULL },
{ "__builtin_signbitl", BT_FN_INT_LONG_DOUBLE, BUILT_IN_SIGNBITL,
BUILT_IN_NORMAL, "signbitl", NULL, NULL },
{ "__builtin_significand", BT_FN_DOUBLE_DOUBLE, BUILT_IN_SIGNIFICAND,
BUILT_IN_NORMAL, "significand", NULL, NULL },
{ "__builtin_significandf", BT_FN_FLOAT_FLOAT, BUILT_IN_SIGNIFICANDF,
BUILT_IN_NORMAL, "significandf", NULL, NULL },
{ "__builtin_significandl", BT_FN_LONG_DOUBLE_LONG_DOUBLE,
BUILT_IN_SIGNIFICANDL, BUILT_IN_NORMAL, "significandl", NULL, NULL },
{ "__builtin_modf", BT_FN_DOUBLE_DOUBLE_DOUBLEPTR, BUILT_IN_MODF,
BUILT_IN_NORMAL, "modf", NULL, NULL },
{ "__builtin_modff", BT_FN_FLOAT_FLOAT_FLOATPTR, BUILT_IN_MODFF,
BUILT_IN_NORMAL, "modff", NULL, NULL },
{ "__builtin_modfl", BT_FN_LONG_DOUBLE_LONG_DOUBLE_LONG_DOUBLEPTR,
BUILT_IN_MODFL, BUILT_IN_NORMAL, "modfl", NULL, NULL },
{ "__builtin_nextafter", BT_FN_DOUBLE_DOUBLE_DOUBLE, BUILT_IN_NEXTAFTER,
BUILT_IN_NORMAL, "nextafter", NULL, NULL },
{ "__builtin_nextafterf", BT_FN_FLOAT_FLOAT_FLOAT, BUILT_IN_NEXTAFTERF,
BUILT_IN_NORMAL, "nextafterf", NULL, NULL },
{ "__builtin_nextafterl", BT_FN_LONG_DOUBLE_LONG_DOUBLE_LONG_DOUBLE,
BUILT_IN_NEXTAFTERL, BUILT_IN_NORMAL, "nextafterl", NULL, NULL },
{ "__builtin_nexttoward", BT_FN_DOUBLE_DOUBLE_LONG_DOUBLE,
BUILT_IN_NEXTTOWARD, BUILT_IN_NORMAL, "nexttoward", NULL, NULL },
{ "__builtin_nexttowardf", BT_FN_FLOAT_FLOAT_LONG_DOUBLE,
BUILT_IN_NEXTTOWARDF, BUILT_IN_NORMAL, "nexttowardf", NULL, NULL },
{ "__builtin_nexttowardl", BT_FN_LONG_DOUBLE_LONG_DOUBLE_LONG_DOUBLE,
BUILT_IN_NEXTTOWARDL, BUILT_IN_NORMAL, "nexttowardl", NULL, NULL },
{ "__builtin_scalb", BT_FN_DOUBLE_DOUBLE_DOUBLE, BUILT_IN_SCALB,
BUILT_IN_NORMAL, "scalb", NULL, NULL },
{ "__builtin_scalbf", BT_FN_FLOAT_FLOAT_FLOAT, BUILT_IN_SCALBF,
BUILT_IN_NORMAL, "scalbf", NULL, NULL },
{ "__builtin_scalbl", BT_FN_LONG_DOUBLE_LONG_DOUBLE_LONG_DOUBLE,
BUILT_IN_SCALBL, BUILT_IN_NORMAL, "scalbl", NULL, NULL },
{ "__builtin_scalbln", BT_FN_DOUBLE_DOUBLE_LONG, BUILT_IN_SCALBLN,
BUILT_IN_NORMAL, "scalbln", NULL, NULL },
{ "__builtin_scalblnf", BT_FN_FLOAT_FLOAT_LONG, BUILT_IN_SCALBLNF,
BUILT_IN_NORMAL, "scalblnf", NULL, NULL },
{ "__builtin_scalblnl", BT_FN_LONG_DOUBLE_LONG_DOUBLE_LONG,
BUILT_IN_SCALBLNL, BUILT_IN_NORMAL, "scalblnl", NULL, NULL },
{ "__builtin_scalbn", BT_FN_DOUBLE_DOUBLE_INT, BUILT_IN_SCALBN,
BUILT_IN_NORMAL, "scalbln", NULL, NULL },
{ "__builtin_scalbnf", BT_FN_FLOAT_FLOAT_INT, BUILT_IN_SCALBNF,
BUILT_IN_NORMAL, "scalblnf", NULL, NULL },
{ "__builtin_scalbnl", BT_FN_LONG_DOUBLE_LONG_DOUBLE_INT, BUILT_IN_SCALBNL,
BUILT_IN_NORMAL, "scalblnl", NULL, NULL },
/* complex intrinsic functions. */
{ "__builtin_cabs", BT_FN_DOUBLE_DCOMPLEX, BUILT_IN_CABS, BUILT_IN_NORMAL,
"cabs", NULL, NULL },
{ "__builtin_cabsf", BT_FN_FLOAT_FCOMPLEX, BUILT_IN_CABSF, BUILT_IN_NORMAL,
"cabsf", NULL, NULL },
{ "__builtin_cabsl", BT_FN_LONG_DOUBLE_LDCOMPLEX, BUILT_IN_CABSL,
BUILT_IN_NORMAL, "cabsl", NULL, NULL },
{ "__builtin_carg", BT_FN_DOUBLE_DCOMPLEX, BUILT_IN_CABS, BUILT_IN_NORMAL,
"carg", NULL, NULL },
{ "__builtin_cargf", BT_FN_FLOAT_FCOMPLEX, BUILT_IN_CABSF, BUILT_IN_NORMAL,
"cargf", NULL, NULL },
{ "__builtin_cargl", BT_FN_LONG_DOUBLE_LDCOMPLEX, BUILT_IN_CABSL,
BUILT_IN_NORMAL, "cargl", NULL, NULL },
{ "__builtin_conj", BT_FN_DCOMPLEX_DCOMPLEX, BUILT_IN_CONJ, BUILT_IN_NORMAL,
"carg", NULL, NULL },
{ "__builtin_conjf", BT_FN_FCOMPLEX_FCOMPLEX, BUILT_IN_CONJF,
BUILT_IN_NORMAL, "conjf", NULL, NULL },
{ "__builtin_conjl", BT_FN_LDCOMPLEX_LDCOMPLEX, BUILT_IN_CONJL,
BUILT_IN_NORMAL, "conjl", NULL, NULL },
{ "__builtin_cpow", BT_FN_DCOMPLEX_DOUBLE_DCOMPLEX, BUILT_IN_CPOW,
BUILT_IN_NORMAL, "cpow", NULL, NULL },
{ "__builtin_cpowf", BT_FN_FCOMPLEX_FLOAT_FCOMPLEX, BUILT_IN_CPOWF,
BUILT_IN_NORMAL, "cpowf", NULL, NULL },
{ "__builtin_cpowl", BT_FN_LDCOMPLEX_LONG_DOUBLE_LDCOMPLEX, BUILT_IN_CPOWL,
BUILT_IN_NORMAL, "cpowl", NULL, NULL },
{ "__builtin_csqrt", BT_FN_DCOMPLEX_DCOMPLEX, BUILT_IN_CSQRT,
BUILT_IN_NORMAL, "csqrt", NULL, NULL },
{ "__builtin_csqrtf", BT_FN_FCOMPLEX_FCOMPLEX, BUILT_IN_CSQRTF,
BUILT_IN_NORMAL, "csqrtf", NULL, NULL },
{ "__builtin_csqrtl", BT_FN_LDCOMPLEX_LDCOMPLEX, BUILT_IN_CSQRTL,
BUILT_IN_NORMAL, "csqrtl", NULL, NULL },
{ "__builtin_cexp", BT_FN_DCOMPLEX_DCOMPLEX, BUILT_IN_CEXP, BUILT_IN_NORMAL,
"cexp", NULL, NULL },
{ "__builtin_cexpf", BT_FN_FCOMPLEX_FCOMPLEX, BUILT_IN_CEXPF,
BUILT_IN_NORMAL, "cexpf", NULL, NULL },
{ "__builtin_cexpl", BT_FN_LDCOMPLEX_LDCOMPLEX, BUILT_IN_CEXPL,
BUILT_IN_NORMAL, "cexpl", NULL, NULL },
{ "__builtin_cln", BT_FN_DCOMPLEX_DCOMPLEX, BUILT_IN_CLOG, BUILT_IN_NORMAL,
"cln", NULL, NULL },
{ "__builtin_clnf", BT_FN_FCOMPLEX_FCOMPLEX, BUILT_IN_CLOGF, BUILT_IN_NORMAL,
"clnf", NULL, NULL },
{ "__builtin_clnl", BT_FN_LDCOMPLEX_LDCOMPLEX, BUILT_IN_CLOGL,
BUILT_IN_NORMAL, "clnl", NULL, NULL },
{ "__builtin_csin", BT_FN_DCOMPLEX_DCOMPLEX, BUILT_IN_CSIN, BUILT_IN_NORMAL,
"csin", NULL, NULL },
{ "__builtin_csinf", BT_FN_FCOMPLEX_FCOMPLEX, BUILT_IN_CSINF,
BUILT_IN_NORMAL, "csinf", NULL, NULL },
{ "__builtin_csinl", BT_FN_LDCOMPLEX_LDCOMPLEX, BUILT_IN_CSINL,
BUILT_IN_NORMAL, "csinl", NULL, NULL },
{ "__builtin_ccos", BT_FN_DCOMPLEX_DCOMPLEX, BUILT_IN_CCOS, BUILT_IN_NORMAL,
"ccos", NULL, NULL },
{ "__builtin_ccosf", BT_FN_FCOMPLEX_FCOMPLEX, BUILT_IN_CCOSF,
BUILT_IN_NORMAL, "ccosf", NULL, NULL },
{ "__builtin_ccosl", BT_FN_LDCOMPLEX_LDCOMPLEX, BUILT_IN_CCOSL,
BUILT_IN_NORMAL, "ccosl", NULL, NULL },
{ "__builtin_ctan", BT_FN_DCOMPLEX_DCOMPLEX, BUILT_IN_CTAN, BUILT_IN_NORMAL,
"ctan", NULL, NULL },
{ "__builtin_ctanf", BT_FN_FCOMPLEX_FCOMPLEX, BUILT_IN_CTANF,
BUILT_IN_NORMAL, "ctanf", NULL, NULL },
{ "__builtin_ctanl", BT_FN_LDCOMPLEX_LDCOMPLEX, BUILT_IN_CTANL,
BUILT_IN_NORMAL, "ctanl", NULL, NULL },
{ "__builtin_casin", BT_FN_DCOMPLEX_DCOMPLEX, BUILT_IN_CASIN,
BUILT_IN_NORMAL, "casin", NULL, NULL },
{ "__builtin_casinf", BT_FN_FCOMPLEX_FCOMPLEX, BUILT_IN_CASINF,
BUILT_IN_NORMAL, "casinf", NULL, NULL },
{ "__builtin_casinl", BT_FN_LDCOMPLEX_LDCOMPLEX, BUILT_IN_CASINL,
BUILT_IN_NORMAL, "casinl", NULL, NULL },
{ "__builtin_cacos", BT_FN_DCOMPLEX_DCOMPLEX, BUILT_IN_CACOS,
BUILT_IN_NORMAL, "cacos", NULL, NULL },
{ "__builtin_cacosf", BT_FN_FCOMPLEX_FCOMPLEX, BUILT_IN_CACOSF,
BUILT_IN_NORMAL, "cacosf", NULL, NULL },
{ "__builtin_cacosl", BT_FN_LDCOMPLEX_LDCOMPLEX, BUILT_IN_CACOSL,
BUILT_IN_NORMAL, "cacosl", NULL, NULL },
{ "__builtin_catan", BT_FN_DCOMPLEX_DCOMPLEX, BUILT_IN_CATAN,
BUILT_IN_NORMAL, "catan", NULL, NULL },
{ "__builtin_catanf", BT_FN_FCOMPLEX_FCOMPLEX, BUILT_IN_CATANF,
BUILT_IN_NORMAL, "catanf", NULL, NULL },
{ "__builtin_catanl", BT_FN_LDCOMPLEX_LDCOMPLEX, BUILT_IN_CATANL,
BUILT_IN_NORMAL, "catanl", NULL, NULL },
{ "__builtin_huge_val", BT_FN_DOUBLE, BUILT_IN_HUGE_VAL, BUILT_IN_NORMAL,
"huge_val", NULL, NULL },
{ "__builtin_huge_valf", BT_FN_FLOAT, BUILT_IN_HUGE_VALF, BUILT_IN_NORMAL,
"huge_valf", NULL, NULL },
{ "__builtin_huge_vall", BT_FN_LONG_DOUBLE, BUILT_IN_HUGE_VALL,
BUILT_IN_NORMAL, "huge_vall", NULL, NULL },
{ "__builtin_index", BT_FN_STRING_CONST_STRING_INT, BUILT_IN_INDEX,
BUILT_IN_NORMAL, "index", NULL, NULL },
{ "__builtin_rindex", BT_FN_STRING_CONST_STRING_INT, BUILT_IN_RINDEX,
BUILT_IN_NORMAL, "rindex", NULL, NULL },
{ "__builtin_memcmp", BT_FN_INT_CONST_PTR_CONST_PTR_SIZE, BUILT_IN_MEMCMP,
BUILT_IN_NORMAL, "memcmp", NULL, NULL },
{ "__builtin_memmove", BT_FN_TRAD_PTR_PTR_CONST_PTR_SIZE, BUILT_IN_MEMMOVE,
BUILT_IN_NORMAL, "memmove", NULL, NULL },
{ "__builtin_memset", BT_FN_TRAD_PTR_PTR_INT_SIZE, BUILT_IN_MEMSET,
BUILT_IN_NORMAL, "memset", NULL, NULL },
{ "__builtin_strcat", BT_FN_STRING_STRING_CONST_STRING, BUILT_IN_STRCAT,
BUILT_IN_NORMAL, "strcat", NULL, NULL },
{ "__builtin_strncat", BT_FN_STRING_STRING_CONST_STRING_SIZE,
BUILT_IN_STRNCAT, BUILT_IN_NORMAL, "strncat", NULL, NULL },
{ "__builtin_strcpy", BT_FN_STRING_STRING_CONST_STRING, BUILT_IN_STRCPY,
BUILT_IN_NORMAL, "strcpy", NULL, NULL },
{ "__builtin_strncpy", BT_FN_STRING_STRING_CONST_STRING_SIZE,
BUILT_IN_STRNCPY, BUILT_IN_NORMAL, "strncpy", NULL, NULL },
{ "__builtin_strcmp", BT_FN_INT_CONST_STRING_CONST_STRING, BUILT_IN_STRCMP,
BUILT_IN_NORMAL, "strcmp", NULL, NULL },
{ "__builtin_strncmp", BT_FN_INT_CONST_STRING_CONST_STRING_SIZE,
BUILT_IN_STRNCMP, BUILT_IN_NORMAL, "strncmp", NULL, NULL },
{ "__builtin_strlen", BT_FN_INT_CONST_STRING, BUILT_IN_STRLEN,
BUILT_IN_NORMAL, "strlen", NULL, NULL },
{ "__builtin_strstr", BT_FN_STRING_CONST_STRING_CONST_STRING,
BUILT_IN_STRSTR, BUILT_IN_NORMAL, "strstr", NULL, NULL },
{ "__builtin_strpbrk", BT_FN_STRING_CONST_STRING_CONST_STRING,
BUILT_IN_STRPBRK, BUILT_IN_NORMAL, "strpbrk", NULL, NULL },
{ "__builtin_strspn", BT_FN_SIZE_CONST_STRING_CONST_STRING, BUILT_IN_STRSPN,
BUILT_IN_NORMAL, "strspn", NULL, NULL },
{ "__builtin_strcspn", BT_FN_SIZE_CONST_STRING_CONST_STRING,
BUILT_IN_STRCSPN, BUILT_IN_NORMAL, "strcspn", NULL, NULL },
{ "__builtin_strchr", BT_FN_STRING_CONST_STRING_INT, BUILT_IN_STRCHR,
BUILT_IN_NORMAL, "strchr", NULL, NULL },
{ "__builtin_strrchr", BT_FN_STRING_CONST_STRING_INT, BUILT_IN_STRCHR,
BUILT_IN_NORMAL, "strrchr", NULL, NULL },
//{ "__builtin_constant_p", BT_FN_INT_VAR, BUILT_IN_CONSTANT_P,
//BUILT_IN_NORMAL, "constant_p", NULL, NULL},
{ "__builtin_frame_address", BT_FN_PTR_UNSIGNED, BUILT_IN_FRAME_ADDRESS,
BUILT_IN_NORMAL, "frame_address", NULL, NULL },
{ "__builtin_return_address", BT_FN_PTR_UNSIGNED, BUILT_IN_RETURN_ADDRESS,
BUILT_IN_NORMAL, "return_address", NULL, NULL },
//{ "__builtin_aggregate_incoming_address", BT_FN_PTR_VAR,
//BUILT_IN_AGGREGATE_INCOMING_ADDRESS, BUILT_IN_NORMAL,
//"aggregate_incoming_address", NULL, NULL},
{ "__builtin_longjmp", BT_FN_VOID_PTR_INT, BUILT_IN_LONGJMP, BUILT_IN_NORMAL,
"longjmp", NULL, NULL },
{ "__builtin_setjmp", BT_FN_INT_PTR, BUILT_IN_SETJMP, BUILT_IN_NORMAL,
"setjmp", NULL, NULL },
{ NULL, BT_FN_NONE, 0, NOT_BUILT_IN, "", NULL, NULL }
};
struct builtin_type_info
{
const char *name;
unsigned int returnType;
tree (*functionHandler) (location_t, tree);
};
static GTY (()) tree sizetype_endlink;
static GTY (()) tree unsigned_endlink;
static GTY (()) tree endlink;
static GTY (()) tree math_endlink;
static GTY (()) tree int_endlink;
static GTY (()) tree ptr_endlink;
static GTY (()) tree const_ptr_endlink;
static GTY (()) tree double_ftype_void;
static GTY (()) tree float_ftype_void;
static GTY (()) tree ldouble_ftype_void;
static GTY (()) tree float_ftype_float;
static GTY (()) tree double_ftype_double;
static GTY (()) tree ldouble_ftype_ldouble;
static GTY (()) tree gm2_alloca_node;
static GTY (()) tree gm2_memcpy_node;
static GTY (()) tree gm2_isfinite_node;
static GTY (()) tree gm2_huge_valf_node;
static GTY (()) tree gm2_huge_val_node;
static GTY (()) tree gm2_huge_vall_node;
static GTY (()) tree long_doubleptr_type_node;
static GTY (()) tree doubleptr_type_node;
static GTY (()) tree floatptr_type_node;
static GTY (()) tree builtin_ftype_int_var;
/* prototypes for locally defined functions. */
static tree DoBuiltinAlloca (location_t location, tree n);
static tree DoBuiltinMemCopy (location_t location, tree dest, tree src,
tree n);
static tree DoBuiltinIsfinite (location_t location, tree value);
static void create_function_prototype (location_t location,
struct builtin_function_entry *fe);
static tree doradix (location_t location, tree type);
static tree doplaces (location_t location, tree type);
static tree doexponentmin (location_t location, tree type);
static tree doexponentmax (location_t location, tree type);
static tree dolarge (location_t location, tree type);
static tree dosmall (location_t location, tree type);
static tree doiec559 (location_t location, tree type);
static tree dolia1 (location_t location, tree type);
static tree doiso (location_t location, tree type);
static tree doieee (location_t location, tree type);
static tree dorounds (location_t location, tree type);
static tree dogUnderflow (location_t location, tree type);
static tree doexception (location_t location, tree type);
static tree doextend (location_t location, tree type);
static tree donModes (location_t location, tree type);
/* prototypes finish here. */
#define m2builtins_c
#include "m2builtins.h"
static struct builtin_type_info m2_type_info[] = {
{ "radix", 2, doradix },
{ "places", 2, doplaces },
{ "expoMin", 2, doexponentmin },
{ "expoMax", 2, doexponentmax },
{ "large", 3, dolarge },
{ "small", 3, dosmall },
{ "IEC559", 1, doiec559 },
{ "LIA1", 1, dolia1 },
{ "ISO", 1, doiso },
{ "IEEE", 1, doieee },
{ "rounds", 1, dorounds },
{ "gUnderflow", 1, dogUnderflow },
{ "exception", 1, doexception },
{ "extend", 1, doextend },
{ "nModes", 2, donModes },
{ NULL, 0, NULL },
};
/* Return a definition for a builtin function named NAME and whose
data type is TYPE. TYPE should be a function type with argument
types. FUNCTION_CODE tells later passes how to compile calls to this
function. See tree.h for its possible values.
If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME, the
name to be called if we can't opencode the function. */
tree
builtin_function (location_t location, const char *name, tree type,
int function_code, enum built_in_class fclass,
const char *library_name, tree attrs)
{
tree decl = add_builtin_function (name, type, function_code, fclass,
library_name, attrs);
DECL_SOURCE_LOCATION (decl) = location;
m2block_pushDecl (decl);
return decl;
}
/* GetBuiltinConst - returns the gcc tree of a builtin constant,
name. NIL is returned if the constant is unknown. */
tree
m2builtins_GetBuiltinConst (char *name)
{
if (strcmp (name, "BITS_PER_UNIT") == 0)
return m2decl_BuildIntegerConstant (BITS_PER_UNIT);
if (strcmp (name, "BITS_PER_WORD") == 0)
return m2decl_BuildIntegerConstant (BITS_PER_WORD);
if (strcmp (name, "BITS_PER_CHAR") == 0)
return m2decl_BuildIntegerConstant (CHAR_TYPE_SIZE);
if (strcmp (name, "UNITS_PER_WORD") == 0)
return m2decl_BuildIntegerConstant (UNITS_PER_WORD);
return NULL_TREE;
}
/* GetBuiltinConstType - returns the type of a builtin constant,
name. 0 = unknown constant name 1 = integer 2 = real. */
unsigned int
m2builtins_GetBuiltinConstType (char *name)
{
if (strcmp (name, "BITS_PER_UNIT") == 0)
return 1;
if (strcmp (name, "BITS_PER_WORD") == 0)
return 1;
if (strcmp (name, "BITS_PER_CHAR") == 0)
return 1;
if (strcmp (name, "UNITS_PER_WORD") == 0)
return 1;
return 0;
}
/* GetBuiltinTypeInfoType - returns value: 0 is ident is unknown. 1
if ident is IEC559, LIA1, ISO, IEEE, rounds, underflow, exception,
extend. 2 if ident is radix, places, exponentmin, exponentmax,
noofmodes. 3 if ident is large, small. */
unsigned int
m2builtins_GetBuiltinTypeInfoType (const char *ident)
{
int i = 0;
while (m2_type_info[i].name != NULL)
if (strcmp (m2_type_info[i].name, ident) == 0)
return m2_type_info[i].returnType;
else
i++;
return 0;
}
/* GetBuiltinTypeInfo - returns value: NULL_TREE if ident is unknown.
boolean Tree if ident is IEC559, LIA1, ISO, IEEE, rounds,
underflow, exception, extend. ZType Tree if ident is radix,
places, exponentmin, exponentmax, noofmodes.
RType Tree if ident is large, small. */
tree
m2builtins_GetBuiltinTypeInfo (location_t location, tree type,
const char *ident)
{
int i = 0;
type = m2tree_skip_type_decl (type);
while (m2_type_info[i].name != NULL)
if (strcmp (m2_type_info[i].name, ident) == 0)
return (*m2_type_info[i].functionHandler) (location, type);
else
i++;
return NULL_TREE;
}
/* doradix - returns the radix of the floating point, type. */
static tree
doradix (location_t location ATTRIBUTE_UNUSED, tree type)
{
if (TREE_CODE (type) == REAL_TYPE)
{
enum machine_mode mode = TYPE_MODE (type);
int radix = REAL_MODE_FORMAT (mode)->b;
return m2decl_BuildIntegerConstant (radix);
}
else
return NULL_TREE;
}
/* doplaces - returns the whole number value of the number of radix
places used to store values of the corresponding real number type. */
static tree
doplaces (location_t location ATTRIBUTE_UNUSED, tree type)
{
if (TREE_CODE (type) == REAL_TYPE)
{
/* taken from c-family/c-cppbuiltin.c. */
/* The number of decimal digits, q, such that any floating-point
number with q decimal digits can be rounded into a
floating-point number with p radix b digits and back again
without change to the q decimal digits, p log10 b if b is a
power of 10 floor((p - 1) log10 b) otherwise. */
enum machine_mode mode = TYPE_MODE (type);
const struct real_format *fmt = REAL_MODE_FORMAT (mode);
const double log10_2 = .30102999566398119521;
double log10_b = log10_2;
int digits = (fmt->p - 1) * log10_b;
return m2decl_BuildIntegerConstant (digits);
}
else
return NULL_TREE;
}
/* doexponentmin - returns the whole number of the exponent minimum. */
static tree
doexponentmin (location_t location ATTRIBUTE_UNUSED, tree type)
{
if (TREE_CODE (type) == REAL_TYPE)
{
enum machine_mode mode = TYPE_MODE (type);
int emin = REAL_MODE_FORMAT (mode)->emin;
return m2decl_BuildIntegerConstant (emin);
}
else
return NULL_TREE;
}
/* doexponentmax - returns the whole number of the exponent maximum. */
static tree
doexponentmax (location_t location ATTRIBUTE_UNUSED, tree type)
{
if (TREE_CODE (type) == REAL_TYPE)
{
enum machine_mode mode = TYPE_MODE (type);
int emax = REAL_MODE_FORMAT (mode)->emax;
return m2decl_BuildIntegerConstant (emax);
}
else
return NULL_TREE;
}
static tree
computeLarge (tree type)
{
enum machine_mode mode = TYPE_MODE (type);
const struct real_format *fmt = REAL_MODE_FORMAT (mode);
REAL_VALUE_TYPE real;
char buf[128];
/* shamelessly taken from c-cppbuiltin.c:builtin_define_float_constants. */
/* Since, for the supported formats, B is always a power of 2, we
construct the following numbers directly as a hexadecimal constants. */
get_max_float (fmt, buf, sizeof (buf), false);
real_from_string (&real, buf);
return build_real (type, real);
}
/* dolarge - return the largest value of the corresponding real type. */
static tree
dolarge (location_t location ATTRIBUTE_UNUSED, tree type)
{
if (TREE_CODE (type) == REAL_TYPE)
return computeLarge (type);
return NULL_TREE;
}
static tree
computeSmall (tree type)
{
enum machine_mode mode = TYPE_MODE (type);
const struct real_format *fmt = REAL_MODE_FORMAT (mode);
REAL_VALUE_TYPE real;
char buf[128];
/* The minimum normalized positive floating-point number,
b**(emin-1). */
sprintf (buf, "0x1p%d", fmt->emin - 1);
real_from_string (&real, buf);
return build_real (type, real);
}
/* dosmall - return the smallest positive value of the corresponding
real type. */
static tree
dosmall (location_t location ATTRIBUTE_UNUSED, tree type)
{
if (TREE_CODE (type) == REAL_TYPE)
return computeSmall (type);
return NULL_TREE;
}
/* doiec559 - a boolean value that is true if and only if the
implementation of the corresponding real number type conforms to
IEC 559:1989 (also known as IEEE 754:1987) in all regards. */
static tree
doiec559 (location_t location, tree type)
{
if (m2expr_IsTrue (m2expr_BuildEqualTo (location,
m2decl_BuildIntegerConstant (32),
m2expr_GetSizeOfInBits (type))))
return m2type_GetBooleanTrue ();
if (m2expr_IsTrue (m2expr_BuildEqualTo (location,
m2decl_BuildIntegerConstant (64),
m2expr_GetSizeOfInBits (type))))
return m2type_GetBooleanTrue ();
return m2type_GetBooleanFalse ();
}
/* dolia1 - returns TRUE if using ieee (currently always TRUE). */
static tree
dolia1 (location_t location, tree type)
{
return doieee (location, type);
}
/* doiso - returns TRUE if using ieee (--fixme--). */
static tree
doiso (location_t location, tree type)
{
return doieee (location, type);
}
/* doieee - returns TRUE if ieee arithmetic is being used. */
static tree
doieee (location_t location ATTRIBUTE_UNUSED, tree type ATTRIBUTE_UNUSED)
{
/* --fixme-- maybe we should look for the -mno-ieee flag and return this
result. */
return m2type_GetBooleanTrue ();
}
/* dorounds - returns TRUE if and only if each operation produces a
result that is one of the values of the corresponding real number
type nearest to the mathematical result. */
static tree
dorounds (location_t location ATTRIBUTE_UNUSED, tree type ATTRIBUTE_UNUSED)
{
if (FLT_ROUNDS)
return m2type_GetBooleanTrue ();
else
return m2type_GetBooleanFalse ();
}
/* dogUnderflow - returns TRUE if and only if there are values of the
corresponding real number type between 0.0 and small. */
static tree
dogUnderflow (location_t location ATTRIBUTE_UNUSED, tree type)
{
if (TREE_CODE (type) == REAL_TYPE)
{
enum machine_mode mode = TYPE_MODE (type);
const struct real_format *fmt = REAL_MODE_FORMAT (mode);
if (fmt->has_denorm)
return m2type_GetBooleanTrue ();
else
return m2type_GetBooleanFalse ();
}
return NULL_TREE;
}
/* doexception - */
static tree
doexception (location_t location ATTRIBUTE_UNUSED, tree type ATTRIBUTE_UNUSED)
{
return m2type_GetBooleanTrue ();
}
/* doextend - */
static tree
doextend (location_t location ATTRIBUTE_UNUSED, tree type ATTRIBUTE_UNUSED)
{
return m2type_GetBooleanTrue ();
}
/* donModes - */
static tree
donModes (location_t location ATTRIBUTE_UNUSED, tree type ATTRIBUTE_UNUSED)
{
return m2decl_BuildIntegerConstant (1);
}
/* BuiltInMemCopy - copy n bytes of memory efficiently from address
src to dest. */
tree
m2builtins_BuiltInMemCopy (location_t location, tree dest, tree src, tree n)
{
return DoBuiltinMemCopy (location, dest, src, n);
}
/* BuiltInAlloca - given an expression, n, allocate, n, bytes on the
stack for the life of the current function. */
tree
m2builtins_BuiltInAlloca (location_t location, tree n)
{
return DoBuiltinAlloca (location, n);
}
/* BuiltInIsfinite - return integer 1 if the real expression is
finite. return integer 0 if it is not finite. */
tree
m2builtins_BuiltInIsfinite (location_t location, tree expression)
{
return DoBuiltinIsfinite (location, expression);
}
/* BuiltinExists - returns TRUE if the builtin function, name, exists
for this target architecture. */
int
m2builtins_BuiltinExists (char *name)
{
struct builtin_function_entry *fe;
for (fe = &list_of_builtins[0]; fe->name != NULL; fe++)
if (strcmp (name, fe->name) == 0)
return TRUE;
return FALSE;
}
/* BuildBuiltinTree - returns a Tree containing the builtin function,
name. */
tree
m2builtins_BuildBuiltinTree (location_t location, char *name)
{
struct builtin_function_entry *fe;
tree t;
m2statement_SetLastFunction (NULL_TREE);
for (fe = &list_of_builtins[0]; fe->name != NULL; fe++)
if (strcmp (name, fe->name) == 0)
{
tree functype = TREE_TYPE (fe->function_node);
tree funcptr = build1 (ADDR_EXPR, build_pointer_type (functype),
fe->function_node);
m2statement_SetLastFunction (m2treelib_DoCall (
location, fe->return_node, funcptr, m2statement_GetParamList ()));
m2statement_SetParamList (NULL_TREE);
t = m2statement_GetLastFunction ();
if (fe->return_node == void_type_node)
m2statement_SetLastFunction (NULL_TREE);
return t;
}
m2statement_SetParamList (NULL_TREE);
return m2statement_GetLastFunction ();
}
static tree
DoBuiltinMemCopy (location_t location, tree dest, tree src, tree bytes)
{
tree functype = TREE_TYPE (gm2_memcpy_node);
tree funcptr
= build1 (ADDR_EXPR, build_pointer_type (functype), gm2_memcpy_node);
tree call
= m2treelib_DoCall3 (location, ptr_type_node, funcptr, dest, src, bytes);
return call;
}
static tree
DoBuiltinAlloca (location_t location, tree bytes)
{
tree functype = TREE_TYPE (gm2_alloca_node);
tree funcptr
= build1 (ADDR_EXPR, build_pointer_type (functype), gm2_alloca_node);
tree call = m2treelib_DoCall1 (location, ptr_type_node, funcptr, bytes);
return call;
}
static tree
DoBuiltinIsfinite (location_t location, tree value)
{
tree functype = TREE_TYPE (gm2_isfinite_node);
tree funcptr
= build1 (ADDR_EXPR, build_pointer_type (functype), gm2_isfinite_node);
tree call = m2treelib_DoCall1 (location, ptr_type_node, funcptr, value);
return call;
}
tree
m2builtins_BuiltInHugeVal (location_t location)
{
tree functype = TREE_TYPE (gm2_huge_val_node);
tree funcptr
= build1 (ADDR_EXPR, build_pointer_type (functype), gm2_huge_val_node);
tree call = m2treelib_DoCall0 (location, ptr_type_node, funcptr);
return call;
}
tree
m2builtins_BuiltInHugeValShort (location_t location)
{
tree functype = TREE_TYPE (gm2_huge_valf_node);
tree funcptr
= build1 (ADDR_EXPR, build_pointer_type (functype), gm2_huge_valf_node);
tree call = m2treelib_DoCall0 (location, ptr_type_node, funcptr);
return call;
}
tree
m2builtins_BuiltInHugeValLong (location_t location)
{
tree functype = TREE_TYPE (gm2_huge_vall_node);
tree funcptr
= build1 (ADDR_EXPR, build_pointer_type (functype), gm2_huge_vall_node);
tree call = m2treelib_DoCall0 (location, ptr_type_node, funcptr);
return call;
}
static void
create_function_prototype (location_t location,
struct builtin_function_entry *fe)
{
tree ftype;
switch (fe->defn)
{
case BT_FN_PTR_SIZE:
ftype = build_function_type (ptr_type_node, sizetype_endlink);
fe->return_node = ptr_type_node;
break;
case BT_FN_STRING_STRING_CONST_STRING_SIZE:
case BT_FN_TRAD_PTR_PTR_CONST_PTR_SIZE:
ftype = build_function_type (
ptr_type_node, tree_cons (NULL_TREE, ptr_type_node,
tree_cons (NULL_TREE, const_ptr_type_node,
sizetype_endlink)));
fe->return_node = ptr_type_node;
break;
case BT_FN_FLOAT:
ftype = float_ftype_void;
fe->return_node = float_type_node;
break;
case BT_FN_DOUBLE:
ftype = double_ftype_void;
fe->return_node = double_type_node;
break;
case BT_FN_LONG_DOUBLE:
ftype = ldouble_ftype_void;
fe->return_node = long_double_type_node;
break;
case BT_FN_FLOAT_FLOAT:
ftype = float_ftype_float;
fe->return_node = float_type_node;
break;
case BT_FN_DOUBLE_DOUBLE:
ftype = double_ftype_double;
fe->return_node = double_type_node;
break;
case BT_FN_LONG_DOUBLE_LONG_DOUBLE:
ftype = ldouble_ftype_ldouble;
fe->return_node = long_double_type_node;
break;
case BT_FN_STRING_CONST_STRING_INT:
ftype = build_function_type (
ptr_type_node, tree_cons (NULL_TREE, ptr_type_node, int_endlink));
fe->return_node = ptr_type_node;
break;
case BT_FN_INT_CONST_PTR_CONST_PTR_SIZE:
ftype = build_function_type (
integer_type_node,
tree_cons (NULL_TREE, const_ptr_type_node,
tree_cons (NULL_TREE, const_ptr_type_node, int_endlink)));
fe->return_node = integer_type_node;
break;
case BT_FN_TRAD_PTR_PTR_INT_SIZE:
ftype = build_function_type (
ptr_type_node, tree_cons (NULL_TREE, ptr_type_node,
tree_cons (NULL_TREE, integer_type_node,
sizetype_endlink)));
fe->return_node = ptr_type_node;
break;
case BT_FN_STRING_STRING_CONST_STRING:
ftype = build_function_type (
ptr_type_node, tree_cons (NULL_TREE, ptr_type_node, ptr_endlink));
fe->return_node = ptr_type_node;
break;
case BT_FN_INT_CONST_STRING_CONST_STRING:
ftype = build_function_type (
integer_type_node,
tree_cons (NULL_TREE, const_ptr_type_node, ptr_endlink));
fe->return_node = integer_type_node;
break;
case BT_FN_INT_CONST_STRING_CONST_STRING_SIZE:
ftype = build_function_type (
integer_type_node,
tree_cons (
NULL_TREE, const_ptr_type_node,
tree_cons (NULL_TREE, const_ptr_type_node, sizetype_endlink)));
fe->return_node = integer_type_node;
break;
case BT_FN_INT_CONST_STRING:
ftype = build_function_type (integer_type_node, ptr_endlink);
fe->return_node = integer_type_node;
break;
case BT_FN_STRING_CONST_STRING_CONST_STRING:
ftype = build_function_type (
ptr_type_node,
tree_cons (NULL_TREE, const_ptr_type_node, const_ptr_endlink));
fe->return_node = ptr_type_node;
break;
case BT_FN_SIZE_CONST_STRING_CONST_STRING:
ftype = build_function_type (
sizetype,
tree_cons (NULL_TREE, const_ptr_type_node, const_ptr_endlink));
fe->return_node = sizetype;
break;
case BT_FN_PTR_UNSIGNED:
ftype = build_function_type (ptr_type_node, unsigned_endlink);
fe->return_node = ptr_type_node;
break;
case BT_FN_VOID_PTR_INT:
ftype = build_function_type (
void_type_node, tree_cons (NULL_TREE, ptr_type_node, int_endlink));
fe->return_node = void_type_node;
break;
case BT_FN_INT_PTR:
ftype = build_function_type (integer_type_node, ptr_endlink);
fe->return_node = integer_type_node;
break;
case BT_FN_INT_FLOAT:
ftype = build_function_type (
integer_type_node, tree_cons (NULL_TREE, float_type_node, endlink));
fe->return_node = integer_type_node;
break;
case BT_FN_INT_DOUBLE:
ftype = build_function_type (
integer_type_node, tree_cons (NULL_TREE, double_type_node, endlink));
fe->return_node = integer_type_node;
break;
case BT_FN_INT_LONG_DOUBLE:
ftype = build_function_type (
integer_type_node,
tree_cons (NULL_TREE, long_double_type_node, endlink));
fe->return_node = integer_type_node;
break;
case BT_FN_FLOAT_FCOMPLEX:
ftype = build_function_type (
float_type_node,
tree_cons (NULL_TREE, complex_float_type_node, endlink));
fe->return_node = float_type_node;
break;
case BT_FN_DOUBLE_DCOMPLEX:
ftype = build_function_type (
double_type_node,
tree_cons (NULL_TREE, complex_double_type_node, endlink));
fe->return_node = double_type_node;
break;
case BT_FN_LONG_DOUBLE_LDCOMPLEX:
ftype = build_function_type (
long_double_type_node,
tree_cons (NULL_TREE, complex_long_double_type_node, endlink));
fe->return_node = long_double_type_node;
break;
case BT_FN_FCOMPLEX_FCOMPLEX:
ftype = build_function_type (
complex_float_type_node,
tree_cons (NULL_TREE, complex_float_type_node, endlink));
fe->return_node = complex_float_type_node;
break;
case BT_FN_DCOMPLEX_DCOMPLEX:
ftype = build_function_type (
complex_double_type_node,
tree_cons (NULL_TREE, complex_double_type_node, endlink));
fe->return_node = complex_double_type_node;
break;
case BT_FN_LDCOMPLEX_LDCOMPLEX:
ftype = build_function_type (
complex_long_double_type_node,
tree_cons (NULL_TREE, complex_long_double_type_node, endlink));
fe->return_node = complex_long_double_type_node;
break;
case BT_FN_DCOMPLEX_DOUBLE_DCOMPLEX:
ftype = build_function_type (
complex_double_type_node,
tree_cons (NULL_TREE, complex_double_type_node,
tree_cons (NULL_TREE, double_type_node, endlink)));
fe->return_node = complex_double_type_node;
break;
case BT_FN_FCOMPLEX_FLOAT_FCOMPLEX:
ftype = build_function_type (
complex_float_type_node,
tree_cons (NULL_TREE, complex_float_type_node,
tree_cons (NULL_TREE, float_type_node, endlink)));
fe->return_node = complex_float_type_node;
break;
case BT_FN_LDCOMPLEX_LONG_DOUBLE_LDCOMPLEX:
ftype = build_function_type (
complex_long_double_type_node,
tree_cons (NULL_TREE, complex_long_double_type_node,
tree_cons (NULL_TREE, long_double_type_node, endlink)));
fe->return_node = complex_long_double_type_node;
break;
case BT_FN_FLOAT_FLOAT_FLOATPTR:
ftype = build_function_type (
float_type_node,
tree_cons (NULL_TREE, float_type_node,
tree_cons (NULL_TREE, floatptr_type_node, endlink)));
fe->return_node = float_type_node;
break;
case BT_FN_DOUBLE_DOUBLE_DOUBLEPTR:
ftype = build_function_type (
double_type_node,
tree_cons (NULL_TREE, double_type_node,
tree_cons (NULL_TREE, doubleptr_type_node, endlink)));
fe->return_node = double_type_node;
break;
case BT_FN_LONG_DOUBLE_LONG_DOUBLE_LONG_DOUBLEPTR:
ftype = build_function_type (
long_double_type_node,
tree_cons (
NULL_TREE, long_double_type_node,
tree_cons (NULL_TREE, long_doubleptr_type_node, endlink)));
fe->return_node = long_double_type_node;
break;
case BT_FN_FLOAT_FLOAT_LONG_DOUBLE:
ftype = build_function_type (
float_type_node,
tree_cons (NULL_TREE, float_type_node,
tree_cons (NULL_TREE, long_double_type_node, endlink)));
fe->return_node = float_type_node;
break;
case BT_FN_DOUBLE_DOUBLE_LONG_DOUBLE:
ftype = build_function_type (
double_type_node,
tree_cons (NULL_TREE, double_type_node,
tree_cons (NULL_TREE, long_double_type_node, endlink)));
fe->return_node = double_type_node;
break;
case BT_FN_LONG_DOUBLE_LONG_DOUBLE_LONG_DOUBLE:
ftype = build_function_type (
long_double_type_node,
tree_cons (NULL_TREE, long_double_type_node,
tree_cons (NULL_TREE, long_double_type_node, endlink)));
fe->return_node = long_double_type_node;
break;
case BT_FN_FLOAT_FLOAT_LONG:
ftype = build_function_type (
float_type_node,
tree_cons (NULL_TREE, float_type_node,
tree_cons (NULL_TREE, long_integer_type_node, endlink)));
fe->return_node = float_type_node;
break;
case BT_FN_DOUBLE_DOUBLE_LONG:
ftype = build_function_type (
double_type_node,
tree_cons (NULL_TREE, double_type_node,
tree_cons (NULL_TREE, long_integer_type_node, endlink)));
fe->return_node = double_type_node;
break;
case BT_FN_LONG_DOUBLE_LONG_DOUBLE_LONG:
ftype = build_function_type (
long_double_type_node,
tree_cons (NULL_TREE, long_double_type_node,
tree_cons (NULL_TREE, long_integer_type_node, endlink)));
fe->return_node = long_double_type_node;
break;
case BT_FN_FLOAT_FLOAT_INT:
ftype = build_function_type (
float_type_node,
tree_cons (NULL_TREE, float_type_node,
tree_cons (NULL_TREE, integer_type_node, endlink)));
fe->return_node = float_type_node;
break;
case BT_FN_DOUBLE_DOUBLE_INT:
ftype = build_function_type (
double_type_node,
tree_cons (NULL_TREE, double_type_node,
tree_cons (NULL_TREE, integer_type_node, endlink)));
fe->return_node = double_type_node;
break;
case BT_FN_LONG_DOUBLE_LONG_DOUBLE_INT:
ftype = build_function_type (
long_double_type_node,
tree_cons (NULL_TREE, long_double_type_node,
tree_cons (NULL_TREE, integer_type_node, endlink)));
fe->return_node = long_double_type_node;
break;
case BT_FN_FLOAT_FLOAT_FLOAT:
ftype = build_function_type (
float_type_node,
tree_cons (NULL_TREE, float_type_node,
tree_cons (NULL_TREE, float_type_node, endlink)));
fe->return_node = float_type_node;
break;
case BT_FN_DOUBLE_DOUBLE_DOUBLE:
ftype = build_function_type (
double_type_node,
tree_cons (NULL_TREE, double_type_node,
tree_cons (NULL_TREE, double_type_node, endlink)));
fe->return_node = double_type_node;
break;
default:
ERROR ("enum has no case");
}
fe->function_node
= builtin_function (location, fe->name, ftype, fe->function_code,
fe->fclass, fe->library_name, NULL);
}
static tree
find_builtin_tree (const char *name)
{
struct builtin_function_entry *fe;
for (fe = &list_of_builtins[0]; fe->name != NULL; fe++)
if (strcmp (name, fe->name) == 0)
return fe->function_node;
ERROR ("cannot find builtin function");
return NULL_TREE;
}
static void
set_decl_built_in_class (tree decl, built_in_class c)
{
FUNCTION_DECL_CHECK (decl)->function_decl.built_in_class = c;
}
static void
set_decl_function_code (tree decl, built_in_function f)
{
tree_function_decl &fndecl = FUNCTION_DECL_CHECK (decl)->function_decl;
fndecl.function_code = f;
}
/* Define a single builtin. */
static void
define_builtin (enum built_in_function val, const char *name, tree type,
const char *libname, int flags)
{
tree decl;
decl = build_decl (BUILTINS_LOCATION, FUNCTION_DECL, get_identifier (name),
type);
DECL_EXTERNAL (decl) = 1;
TREE_PUBLIC (decl) = 1;
SET_DECL_ASSEMBLER_NAME (decl, get_identifier (libname));
m2block_pushDecl (decl);
set_decl_built_in_class (decl, BUILT_IN_NORMAL);
set_decl_function_code (decl, val);
set_call_expr_flags (decl, flags);
set_builtin_decl (val, decl, true);
}
void
m2builtins_init (location_t location)
{
int i;
m2block_pushGlobalScope ();
endlink = void_list_node;
sizetype_endlink = tree_cons (NULL_TREE, sizetype, endlink);
math_endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
int_endlink = tree_cons (NULL_TREE, integer_type_node, NULL_TREE);
ptr_endlink = tree_cons (NULL_TREE, ptr_type_node, NULL_TREE);
const_ptr_endlink = tree_cons (NULL_TREE, const_ptr_type_node, NULL_TREE);
unsigned_endlink = tree_cons (NULL_TREE, unsigned_type_node, NULL_TREE);
float_ftype_void = build_function_type (float_type_node, math_endlink);
double_ftype_void = build_function_type (double_type_node, math_endlink);
ldouble_ftype_void
= build_function_type (long_double_type_node, math_endlink);
long_doubleptr_type_node = build_pointer_type (long_double_type_node);
doubleptr_type_node = build_pointer_type (double_type_node);
floatptr_type_node = build_pointer_type (float_type_node);
float_ftype_float = build_function_type (
float_type_node, tree_cons (NULL_TREE, float_type_node, math_endlink));
double_ftype_double = build_function_type (
double_type_node, tree_cons (NULL_TREE, double_type_node, math_endlink));
ldouble_ftype_ldouble = build_function_type (
long_double_type_node,
tree_cons (NULL_TREE, long_double_type_node, endlink));
builtin_ftype_int_var = build_function_type (
integer_type_node, tree_cons (NULL_TREE, double_type_node, endlink));
for (i = 0; list_of_builtins[i].name != NULL; i++)
create_function_prototype (location, &list_of_builtins[i]);
define_builtin (BUILT_IN_TRAP, "__builtin_trap",
build_function_type_list (void_type_node, NULL_TREE),
"__builtin_trap", ECF_NOTHROW | ECF_LEAF | ECF_NORETURN);
define_builtin (BUILT_IN_ISGREATER, "isgreater", builtin_ftype_int_var,
"__builtin_isgreater", ECF_CONST | ECF_NOTHROW | ECF_LEAF);
define_builtin (BUILT_IN_ISGREATEREQUAL, "isgreaterequal",
builtin_ftype_int_var, "__builtin_isgreaterequal",
ECF_CONST | ECF_NOTHROW | ECF_LEAF);
define_builtin (BUILT_IN_ISLESS, "isless", builtin_ftype_int_var,
"__builtin_isless", ECF_CONST | ECF_NOTHROW | ECF_LEAF);
define_builtin (BUILT_IN_ISLESSEQUAL, "islessequal", builtin_ftype_int_var,
"__builtin_islessequal", ECF_CONST | ECF_NOTHROW | ECF_LEAF);
define_builtin (BUILT_IN_ISLESSGREATER, "islessgreater",
builtin_ftype_int_var, "__builtin_islessgreater",
ECF_CONST | ECF_NOTHROW | ECF_LEAF);
define_builtin (BUILT_IN_ISUNORDERED, "isunordered", builtin_ftype_int_var,
"__builtin_isunordered", ECF_CONST | ECF_NOTHROW | ECF_LEAF);
gm2_alloca_node = find_builtin_tree ("__builtin_alloca");
gm2_memcpy_node = find_builtin_tree ("__builtin_memcpy");
gm2_huge_valf_node = find_builtin_tree ("__builtin_huge_valf");
gm2_huge_val_node = find_builtin_tree ("__builtin_huge_val");
gm2_huge_vall_node = find_builtin_tree ("__builtin_huge_vall");
gm2_isfinite_node = find_builtin_tree ("__builtin_isfinite");
m2block_popGlobalScope ();
}
#include "gt-m2-m2builtins.h"
/* END m2builtins. */
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2022-05-18 13:46 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2022-05-18 13:45 [PATCH] Modula-2: merge proposal/review: 4/9 04.patch-set-04-1 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).