gcc/m2/gm2-lang.cc

   1 /* gm2-lang.cc language-dependent hooks for GNU Modula-2.
   2
   3 Copyright (C) 2002-2022 Free Software Foundation, Inc.
   4 Contributed by Gaius Mulley <gaius@glam.ac.uk>.
   5
   6 This file is part of GNU Modula-2.
   7
   8 GNU Modula-2 is free software; you can redistribute it and/or modify
   9 it under the terms of the GNU General Public License as published by
  10 the Free Software Foundation; either version 3, or (at your option)
  11 any later version.
  12
  13 GNU Modula-2 is distributed in the hope that it will be useful, but
  14 WITHOUT ANY WARRANTY; without even the implied warranty of
  15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  16 General Public License for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GNU Modula-2; see the file COPYING.  If not, write to the
  20 Free Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
  21 02110-1301, USA.  */
  22
  23 #include "gm2-gcc/gcc-consolidation.h"
  24
  25 #include "langhooks-def.h" /* FIXME: for lhd_set_decl_assembler_name.  */
  26 #include "tree-pass.h"     /* FIXME: only for PROP_gimple_any.  */
  27 #include "toplev.h"
  28 #include "debug.h"
  29
  30 #include "opts.h"
  31
  32 #define GM2_LANG_C
  33 #include "gm2-lang.h"
  34 #include "m2block.h"
  35 #include "dynamicstrings.h"
  36 #include "m2options.h"
  37 #include "m2convert.h"
  38 #include "m2linemap.h"
  39 #include "init.h"
  40 #include "m2-tree.h"
  41 #include "convert.h"
  42 #include "rtegraph.h"
  43
  44 static void write_globals (void);
  45
  46 static int insideCppArgs = FALSE;
  47
  48 #define EXPR_STMT_EXPR(NODE) TREE_OPERAND (EXPR_STMT_CHECK (NODE), 0)
  49
  50 /* start of new stuff.  */
  51
  52 /* Language-dependent contents of a type.  */
  53
  54 struct GTY (()) lang_type
  55 {
  56   char dummy;
  57 };
  58
  59 /* Language-dependent contents of a decl.  */
  60
  61 struct GTY (()) lang_decl
  62 {
  63   char dummy;
  64 };
  65
  66 /* Language-dependent contents of an identifier.  This must include a
  67    tree_identifier.  */
  68
  69 struct GTY (()) lang_identifier
  70 {
  71   struct tree_identifier common;
  72 };
  73
  74 /* The resulting tree type.  */
  75
  76 union GTY ((desc ("TREE_CODE (&%h.generic) == IDENTIFIER_NODE"),
  77             chain_next ("CODE_CONTAINS_STRUCT (TREE_CODE (&%h.generic), "
  78                         "TS_COMMON) ? ((union lang_tree_node *) TREE_CHAIN "
  79                         "(&%h.generic)) : NULL"))) lang_tree_node
  80 {
  81   union tree_node GTY ((tag ("0"),
  82                         desc ("tree_node_structure (&%h)"))) generic;
  83   struct lang_identifier GTY ((tag ("1"))) identifier;
  84 };
  85
  86 struct GTY (()) language_function
  87 {
  88
  89   /* While we are parsing the function, this contains information about
  90   the statement-tree that we are building.  */
  91   /* struct stmt_tree_s stmt_tree;  */
  92   tree stmt_tree;
  93 };
  94
  95 /* Language hooks.  */
  96
  97 bool
  98 gm2_langhook_init (void)
  99 {
 100   build_common_tree_nodes (false);
 101   build_common_builtin_nodes ();
 102
 103   /* The default precision for floating point numbers.  This is used
 104      for floating point constants with abstract type.  This may eventually
 105      be controllable by a command line option.  */
 106   mpfr_set_default_prec (256);
 107
 108   /* GNU Modula-2 uses exceptions.  */
 109   using_eh_for_cleanups ();
 110   return true;
 111 }
 112
 113 /* The option mask.  */
 114
 115 static unsigned int
 116 gm2_langhook_option_lang_mask (void)
 117 {
 118   return CL_ModulaX2;
 119 }
 120
 121 /* Initialize the options structure.  */
 122
 123 static void
 124 gm2_langhook_init_options_struct (struct gcc_options *opts)
 125 {
 126   /* Default to avoiding range issues for complex multiply and divide.  */
 127   opts->x_flag_complex_method = 2;
 128
 129   /* The builtin math functions should not set errno.  */
 130   opts->x_flag_errno_math = 0;
 131   opts->frontend_set_flag_errno_math = true;
 132
 133   /* Exceptions are used.  */
 134   opts->x_flag_exceptions = 1;
 135   init_FrontEndInit ();
 136 }
 137
 138 /* Infrastructure for a VEC of bool values.  */
 139
 140 /* This array determines whether the filename is associated with the
 141    C preprocessor.  */
 142
 143 static vec<bool> filename_cpp;
 144
 145 void
 146 gm2_langhook_init_options (unsigned int decoded_options_count,
 147                            struct cl_decoded_option *decoded_options)
 148 {
 149   unsigned int i;
 150   bool in_cpp_args = false;
 151
 152   for (i = 1; i < decoded_options_count; i++)
 153     {
 154       switch (decoded_options[i].opt_index)
 155         {
 156         case OPT_fcpp_begin:
 157           in_cpp_args = true;
 158           break;
 159         case OPT_fcpp_end:
 160           in_cpp_args = false;
 161           break;
 162         case OPT_SPECIAL_input_file:
 163         case OPT_SPECIAL_program_name:
 164           filename_cpp.safe_push (in_cpp_args);
 165         }
 166     }
 167   filename_cpp.safe_push (false);
 168 }
 169
 170 static bool
 171 is_cpp_filename (unsigned int i)
 172 {
 173   gcc_assert (i < filename_cpp.length ());
 174   return filename_cpp[i];
 175 }
 176
 177 /* Handle gm2 specific options.  Return 0 if we didn't do anything.  */
 178
 179 bool
 180 gm2_langhook_handle_option (
 181     size_t scode, const char *arg, HOST_WIDE_INT value, int kind ATTRIBUTE_UNUSED,
 182     location_t loc ATTRIBUTE_UNUSED,
 183     const struct cl_option_handlers *handlers ATTRIBUTE_UNUSED)
 184 {
 185   enum opt_code code = (enum opt_code)scode;
 186
 187   /* ignore file names.  */
 188   if (code == N_OPTS)
 189     return 1;
 190
 191   switch (code)
 192     {
 193     case OPT_B:
 194       M2Options_SetB (arg);
 195       return 1;
 196     case OPT_c:
 197       M2Options_Setc (value);
 198       return 1;
 199     case OPT_I:
 200       if (insideCppArgs)
 201         {
 202           const struct cl_option *option = &cl_options[scode];
 203           const char *opt = (const char *)option->opt_text;
 204           M2Options_CppArg (opt, arg, TRUE);
 205         }
 206       else
 207         M2Options_SetSearchPath (arg);
 208       return 1;
 209     case OPT_fiso:
 210       M2Options_SetISO (value);
 211       return 1;
 212     case OPT_fpim:
 213       M2Options_SetPIM (value);
 214       return 1;
 215     case OPT_fpim2:
 216       M2Options_SetPIM2 (value);
 217       return 1;
 218     case OPT_fpim3:
 219       M2Options_SetPIM3 (value);
 220       return 1;
 221     case OPT_fpim4:
 222       M2Options_SetPIM4 (value);
 223       return 1;
 224     case OPT_fpositive_mod_floor_div:
 225       M2Options_SetPositiveModFloor (value);
 226       return 1;
 227     case OPT_flibs_:
 228       /* handled in the gm2 driver.  */
 229       return 1;
 230     case OPT_fgen_module_list_:
 231       M2Options_SetGenModuleList (value, arg);
 232       return 1;
 233     case OPT_fnil:
 234       M2Options_SetNilCheck (value);
 235       return 1;
 236     case OPT_fwholediv:
 237       M2Options_SetWholeDiv (value);
 238       return 1;
 239     case OPT_findex:
 240       M2Options_SetIndex (value);
 241       return 1;
 242     case OPT_frange:
 243       M2Options_SetRange (value);
 244       return 1;
 245     case OPT_ffloatvalue:
 246       M2Options_SetFloatValueCheck (value);
 247       return 1;
 248     case OPT_fwholevalue:
 249       M2Options_SetWholeValueCheck (value);
 250       return 1;
 251     case OPT_freturn:
 252       M2Options_SetReturnCheck (value);
 253       return 1;
 254     case OPT_fcase:
 255       M2Options_SetCaseCheck (value);
 256       return 1;
 257     case OPT_fd:
 258       M2Options_SetCompilerDebugging (value);
 259       return 1;
 260     case OPT_fdebug_trace_quad:
 261       M2Options_SetDebugTraceQuad (value);
 262       return 1;
 263     case OPT_fdebug_trace_api:
 264       M2Options_SetDebugTraceAPI (value);
 265       return 1;
 266     case OPT_fdebug_function_line_numbers:
 267       M2Options_SetDebugFunctionLineNumbers (value);
 268       return 1;
 269     case OPT_fauto_init:
 270       M2Options_SetAutoInit (value);
 271       return 1;
 272     case OPT_fsoft_check_all:
 273       M2Options_SetCheckAll (value);
 274       return 1;
 275     case OPT_fexceptions:
 276       M2Options_SetExceptions (value);
 277       return 1;
 278     case OPT_Wstyle:
 279       M2Options_SetStyle (value);
 280       return 1;
 281     case OPT_Wpedantic:
 282       M2Options_SetPedantic (value);
 283       return 1;
 284     case OPT_Wpedantic_param_names:
 285       M2Options_SetPedanticParamNames (value);
 286       return 1;
 287     case OPT_Wpedantic_cast:
 288       M2Options_SetPedanticCast (value);
 289       return 1;
 290     case OPT_fextended_opaque:
 291       M2Options_SetExtendedOpaque (value);
 292       return 1;
 293     case OPT_Wverbose_unbounded:
 294       M2Options_SetVerboseUnbounded (value);
 295       return 1;
 296     case OPT_Wunused_variable:
 297       M2Options_SetUnusedVariableChecking (value);
 298       return 1;
 299     case OPT_Wunused_parameter:
 300       M2Options_SetUnusedParameterChecking (value);
 301       return 1;
 302     case OPT_fm2_strict_type:
 303       M2Options_SetStrictTypeChecking (value);
 304       return 1;
 305     case OPT_Wall:
 306       M2Options_SetWall (value);
 307       return 1;
 308 #if 0
 309     /* Not yet implemented.  */
 310     case OPT_fxcode:
 311       M2Options_SetXCode (value);
 312       return 1;
 313 #endif
 314     case OPT_fm2_lower_case:
 315       M2Options_SetLowerCaseKeywords (value);
 316       return 1;
 317     case OPT_fuse_list_:
 318       M2Options_SetUselist (value, arg);
 319       return 1;
 320     case OPT_fruntime_modules_:
 321       M2Options_SetRuntimeModuleOverride (arg);
 322       return 1;
 323     case OPT_fpthread:
 324       /* Handled in the driver.  */
 325       return 1;
 326     case OPT_fm2_plugin:
 327       /* Handled in the driver.  */
 328       return 1;
 329     case OPT_fscaffold_dynamic:
 330       M2Options_SetScaffoldDynamic (value);
 331       return 1;
 332     case OPT_fscaffold_static:
 333       M2Options_SetScaffoldStatic (value);
 334       return 1;
 335     case OPT_fscaffold_main:
 336       M2Options_SetScaffoldMain (value);
 337       return 1;
 338     case OPT_fcpp:
 339       M2Options_SetCpp (value);
 340       return 1;
 341     case OPT_fcpp_begin:
 342       insideCppArgs = TRUE;
 343       return 1;
 344     case OPT_fcpp_end:
 345       insideCppArgs = FALSE;
 346       return 1;
 347     case OPT_fq:
 348       M2Options_SetQuadDebugging (value);
 349       return 1;
 350     case OPT_fsources:
 351       M2Options_SetSources (value);
 352       return 1;
 353     case OPT_funbounded_by_reference:
 354       M2Options_SetUnboundedByReference (value);
 355       return 1;
 356     case OPT_fdef_:
 357       M2Options_setdefextension (arg);
 358       return 1;
 359     case OPT_fmod_:
 360       M2Options_setmodextension (arg);
 361       return 1;
 362     case OPT_fdump_system_exports:
 363       M2Options_SetDumpSystemExports (value);
 364       return 1;
 365     case OPT_fswig:
 366       M2Options_SetSwig (value);
 367       return 1;
 368     case OPT_fshared:
 369       M2Options_SetShared (value);
 370       return 1;
 371     case OPT_fm2_statistics:
 372       M2Options_SetStatistics (value);
 373       return 1;
 374     case OPT_fm2_g:
 375       M2Options_SetM2g (value);
 376       return 1;
 377     case OPT_O:
 378       M2Options_SetOptimizing (value);
 379       return 1;
 380     case OPT_quiet:
 381       M2Options_SetQuiet (value);
 382       return 1;
 383     case OPT_fm2_whole_program:
 384       M2Options_SetWholeProgram (value);
 385       return 1;
 386     case OPT_flocation_:
 387       if (strcmp (arg, "builtins") == 0)
 388         {
 389           M2Options_SetForcedLocation (BUILTINS_LOCATION);
 390           return 1;
 391         }
 392       else if (strcmp (arg, "unknown") == 0)
 393         {
 394           M2Options_SetForcedLocation (UNKNOWN_LOCATION);
 395           return 1;
 396         }
 397       else if ((arg != NULL) && (ISDIGIT (arg[0])))
 398         {
 399           M2Options_SetForcedLocation (atoi (arg));
 400           return 1;
 401         }
 402       else
 403         return 0;
 404     case OPT_save_temps:
 405       M2Options_SetSaveTemps (value);
 406       return 1;
 407     case OPT_save_temps_:
 408       M2Options_SetSaveTempsDir (arg);
 409       return 1;
 410     default:
 411       if (insideCppArgs)
 412         {
 413           const struct cl_option *option = &cl_options[scode];
 414           const char *opt = (const char *)option->opt_text;
 415
 416           M2Options_CppArg (opt, arg, TRUE);
 417           return 1;
 418         }
 419       return 0;
 420     }
 421   return 0;
 422 }
 423
 424 /* Run after parsing options.  */
 425
 426 static bool
 427 gm2_langhook_post_options (const char **pfilename)
 428 {
 429   const char *filename = *pfilename;
 430   flag_excess_precision = EXCESS_PRECISION_FAST;
 431   M2Options_SetCC1Quiet (quiet_flag);
 432   M2Options_FinaliseOptions ();
 433   main_input_filename = filename;
 434
 435   /* Returning false means that the backend should be used.  */
 436   return false;
 437 }
 438
 439 /* Call the compiler for every source filename on the command line.  */
 440
 441 static void
 442 gm2_parse_input_files (const char **filenames, unsigned int filename_count)
 443 {
 444   unsigned int i;
 445   gcc_assert (filename_count > 0);
 446
 447   for (i = 0; i < filename_count; i++)
 448     if (!is_cpp_filename (i))
 449       {
 450         main_input_filename = filenames[i];
 451         init_PerCompilationInit (filenames[i]);
 452       }
 453 }
 454
 455 static void
 456 gm2_langhook_parse_file (void)
 457 {
 458   gm2_parse_input_files (in_fnames, num_in_fnames);
 459   write_globals ();
 460 }
 461
 462 static tree
 463 gm2_langhook_type_for_size (unsigned int bits, int unsignedp)
 464 {
 465   return gm2_type_for_size (bits, unsignedp);
 466 }
 467
 468 static tree
 469 gm2_langhook_type_for_mode (machine_mode mode, int unsignedp)
 470 {
 471   tree type;
 472
 473   for (int i = 0; i < NUM_INT_N_ENTS; i ++)
 474     if (int_n_enabled_p[i]
 475         && mode == int_n_data[i].m)
 476       return (unsignedp ? int_n_trees[i].unsigned_type
 477               : int_n_trees[i].signed_type);
 478
 479   if (VECTOR_MODE_P (mode))
 480     {
 481       tree inner;
 482
 483       inner = gm2_langhook_type_for_mode (GET_MODE_INNER (mode), unsignedp);
 484       if (inner != NULL_TREE)
 485         return build_vector_type_for_mode (inner, mode);
 486       return NULL_TREE;
 487     }
 488
 489   scalar_int_mode imode;
 490   if (is_int_mode (mode, &imode))
 491     return gm2_langhook_type_for_size (GET_MODE_BITSIZE (imode), unsignedp);
 492
 493   if (mode == TYPE_MODE (float_type_node))
 494     return float_type_node;
 495
 496   if (mode == TYPE_MODE (double_type_node))
 497     return double_type_node;
 498
 499   if (mode == TYPE_MODE (long_double_type_node))
 500     return long_double_type_node;
 501
 502   if (COMPLEX_MODE_P (mode))
 503     {
 504       if (mode == TYPE_MODE (complex_float_type_node))
 505         return complex_float_type_node;
 506       if (mode == TYPE_MODE (complex_double_type_node))
 507         return complex_double_type_node;
 508       if (mode == TYPE_MODE (complex_long_double_type_node))
 509         return complex_long_double_type_node;
 510     }
 511
 512 #if HOST_BITS_PER_WIDE_INT >= 64
 513   /* The middle-end and some backends rely on TImode being supported
 514   for 64-bit HWI.  */
 515   if (mode == TImode)
 516     {
 517       type = build_nonstandard_integer_type (GET_MODE_BITSIZE (TImode),
 518                                              unsignedp);
 519       if (type && TYPE_MODE (type) == TImode)
 520         return type;
 521     }
 522 #endif
 523   return NULL_TREE;
 524 }
 525
 526 /* Record a builtin function.  We just ignore builtin functions.  */
 527
 528 static tree
 529 gm2_langhook_builtin_function (tree decl)
 530 {
 531   return decl;
 532 }
 533
 534 /* Return true if we are in the global binding level.  */
 535
 536 static bool
 537 gm2_langhook_global_bindings_p (void)
 538 {
 539   return current_function_decl == NULL_TREE;
 540 }
 541
 542 /* Unused langhook.  */
 543
 544 static tree
 545 gm2_langhook_pushdecl (tree decl ATTRIBUTE_UNUSED)
 546 {
 547   gcc_unreachable ();
 548 }
 549
 550 /* This hook is used to get the current list of declarations as trees.
 551    We don't support that; instead we use write_globals.  This can't
 552    simply crash because it is called by -gstabs.  */
 553
 554 static tree
 555 gm2_langhook_getdecls (void)
 556 {
 557   return NULL;
 558 }
 559
 560 /* m2_write_global_declarations writes out globals creating an array
 561    of the declarations and calling wrapup_global_declarations.  */
 562
 563 static void
 564 m2_write_global_declarations (tree globals)
 565 {
 566   auto_vec<tree> global_decls;
 567   tree decl = globals;
 568   int n = 0;
 569
 570   while (decl != NULL)
 571     {
 572       global_decls.safe_push (decl);
 573       decl = TREE_CHAIN (decl);
 574       n++;
 575     }
 576   wrapup_global_declarations (global_decls.address (), n);
 577 }
 578
 579 /* Write out globals.  */
 580
 581 static void
 582 write_globals (void)
 583 {
 584   tree t;
 585   unsigned i;
 586
 587   m2block_finishGlobals ();
 588
 589   /* Process all file scopes in this compilation, and the
 590      external_scope, through wrapup_global_declarations and
 591      check_global_declarations.  */
 592   FOR_EACH_VEC_ELT (*all_translation_units, i, t)
 593   m2_write_global_declarations (BLOCK_VARS (DECL_INITIAL (t)));
 594 }
 595
 596
 597 /* Gimplify an EXPR_STMT node.  */
 598
 599 static void
 600 gimplify_expr_stmt (tree *stmt_p)
 601 {
 602   gcc_assert (EXPR_STMT_EXPR (*stmt_p) != NULL_TREE);
 603   *stmt_p = EXPR_STMT_EXPR (*stmt_p);
 604 }
 605
 606 /* Genericize a TRY_BLOCK.  */
 607
 608 static void
 609 genericize_try_block (tree *stmt_p)
 610 {
 611   tree body = TRY_STMTS (*stmt_p);
 612   tree cleanup = TRY_HANDLERS (*stmt_p);
 613
 614   *stmt_p = build2 (TRY_CATCH_EXPR, void_type_node, body, cleanup);
 615 }
 616
 617 /* Genericize a HANDLER by converting to a CATCH_EXPR.  */
 618
 619 static void
 620 genericize_catch_block (tree *stmt_p)
 621 {
 622   tree type = HANDLER_TYPE (*stmt_p);
 623   tree body = HANDLER_BODY (*stmt_p);
 624
 625   /* FIXME should the caught type go in TREE_TYPE?  */
 626   *stmt_p = build2 (CATCH_EXPR, void_type_node, type, body);
 627 }
 628
 629 /* Convert the tree representation of FNDECL from m2 frontend trees
 630    to GENERIC.  */
 631
 632 extern void pf (tree);
 633
 634 void
 635 gm2_genericize (tree fndecl)
 636 {
 637   tree t;
 638   struct cgraph_node *cgn;
 639
 640 #if 0
 641   pf (fndecl);
 642 #endif
 643   /* Fix up the types of parms passed by invisible reference.  */
 644   for (t = DECL_ARGUMENTS (fndecl); t; t = DECL_CHAIN (t))
 645     if (TREE_ADDRESSABLE (TREE_TYPE (t)))
 646       {
 647
 648         /* If a function's arguments are copied to create a thunk, then
 649            DECL_BY_REFERENCE will be set -- but the type of the argument will be
 650            a pointer type, so we will never get here.  */
 651         gcc_assert (!DECL_BY_REFERENCE (t));
 652         gcc_assert (DECL_ARG_TYPE (t) != TREE_TYPE (t));
 653         TREE_TYPE (t) = DECL_ARG_TYPE (t);
 654         DECL_BY_REFERENCE (t) = 1;
 655         TREE_ADDRESSABLE (t) = 0;
 656         relayout_decl (t);
 657       }
 658
 659   /* Dump all nested functions now.  */
 660   cgn = cgraph_node::get_create (fndecl);
 661   for (cgn = first_nested_function (cgn);
 662        cgn != NULL; cgn = next_nested_function (cgn))
 663     gm2_genericize (cgn->decl);
 664 }
 665
 666 /* gm2 gimplify expression, currently just change THROW in the same
 667    way as C++ */
 668
 669 static int
 670 gm2_langhook_gimplify_expr (tree *expr_p, gimple_seq *pre_p ATTRIBUTE_UNUSED,
 671                             gimple_seq *post_p ATTRIBUTE_UNUSED)
 672 {
 673   enum tree_code code = TREE_CODE (*expr_p);
 674
 675   switch (code)
 676     {
 677     case THROW_EXPR:
 678
 679       /* FIXME communicate throw type to back end, probably by moving
 680       THROW_EXPR into ../tree.def.  */
 681       *expr_p = TREE_OPERAND (*expr_p, 0);
 682       return GS_OK;
 683
 684     case EXPR_STMT:
 685       gimplify_expr_stmt (expr_p);
 686       return GS_OK;
 687
 688     case TRY_BLOCK:
 689       genericize_try_block (expr_p);
 690       return GS_OK;
 691
 692     case HANDLER:
 693       genericize_catch_block (expr_p);
 694       return GS_OK;
 695
 696     default:
 697       return GS_UNHANDLED;
 698     }
 699 }
 700
 701 static GTY(()) tree gm2_eh_personality_decl;
 702
 703 static tree
 704 gm2_langhook_eh_personality (void)
 705 {
 706   if (!gm2_eh_personality_decl)
 707     gm2_eh_personality_decl = build_personality_function ("gxx");
 708
 709   return gm2_eh_personality_decl;
 710 }
 711
 712 /* Functions called directly by the generic backend.  */
 713
 714 tree
 715 convert_loc (location_t location, tree type, tree expr)
 716 {
 717   if (type == error_mark_node || expr == error_mark_node
 718       || TREE_TYPE (expr) == error_mark_node)
 719     return error_mark_node;
 720
 721   if (type == TREE_TYPE (expr))
 722     return expr;
 723
 724   gcc_assert (TYPE_MAIN_VARIANT (type) != NULL);
 725   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (expr)))
 726     return fold_convert (type, expr);
 727
 728   expr = m2convert_GenericToType (location, type, expr);
 729   switch (TREE_CODE (type))
 730     {
 731     case VOID_TYPE:
 732     case BOOLEAN_TYPE:
 733       return fold_convert (type, expr);
 734     case INTEGER_TYPE:
 735       return fold (convert_to_integer (type, expr));
 736     case POINTER_TYPE:
 737       return fold (convert_to_pointer (type, expr));
 738     case REAL_TYPE:
 739       return fold (convert_to_real (type, expr));
 740     case COMPLEX_TYPE:
 741       return fold (convert_to_complex (type, expr));
 742     case ENUMERAL_TYPE:
 743       return fold (convert_to_integer (type, expr));
 744     default:
 745       error_at (location, "cannot convert expression, only base types can be converted");
 746       break;
 747     }
 748   return error_mark_node;
 749 }
 750
 751 /* Functions called directly by the generic backend.  */
 752
 753 tree
 754 convert (tree type, tree expr)
 755 {
 756   return convert_loc (m2linemap_UnknownLocation (), type, expr);
 757 }
 758
 759 /* Mark EXP saying that we need to be able to take the address of it;
 760    it should not be allocated in a register.  Returns true if
 761    successful.  */
 762
 763 bool
 764 gm2_mark_addressable (tree exp)
 765 {
 766   tree x = exp;
 767
 768   while (TRUE)
 769     switch (TREE_CODE (x))
 770       {
 771       case COMPONENT_REF:
 772         if (DECL_PACKED (TREE_OPERAND (x, 1)))
 773           return false;
 774         x = TREE_OPERAND (x, 0);
 775         break;
 776
 777       case ADDR_EXPR:
 778       case ARRAY_REF:
 779       case REALPART_EXPR:
 780       case IMAGPART_EXPR:
 781         x = TREE_OPERAND (x, 0);
 782         break;
 783
 784       case COMPOUND_LITERAL_EXPR:
 785       case CONSTRUCTOR:
 786       case STRING_CST:
 787       case VAR_DECL:
 788       case CONST_DECL:
 789       case PARM_DECL:
 790       case RESULT_DECL:
 791       case FUNCTION_DECL:
 792         TREE_ADDRESSABLE (x) = 1;
 793         return true;
 794       default:
 795         return true;
 796       }
 797   /* Never reach here.  */
 798   gcc_unreachable ();
 799 }
 800
 801 /* Return an integer type with BITS bits of precision, that is
 802    unsigned if UNSIGNEDP is nonzero, otherwise signed.  */
 803
 804 tree
 805 gm2_type_for_size (unsigned int bits, int unsignedp)
 806 {
 807   tree type;
 808
 809   if (unsignedp)
 810     {
 811       if (bits == INT_TYPE_SIZE)
 812         type = unsigned_type_node;
 813       else if (bits == CHAR_TYPE_SIZE)
 814         type = unsigned_char_type_node;
 815       else if (bits == SHORT_TYPE_SIZE)
 816         type = short_unsigned_type_node;
 817       else if (bits == LONG_TYPE_SIZE)
 818         type = long_unsigned_type_node;
 819       else if (bits == LONG_LONG_TYPE_SIZE)
 820         type = long_long_unsigned_type_node;
 821       else
 822         type = build_nonstandard_integer_type (bits,
 823                                                unsignedp);
 824     }
 825   else
 826     {
 827       if (bits == INT_TYPE_SIZE)
 828         type = integer_type_node;
 829       else if (bits == CHAR_TYPE_SIZE)
 830         type = signed_char_type_node;
 831       else if (bits == SHORT_TYPE_SIZE)
 832         type = short_integer_type_node;
 833       else if (bits == LONG_TYPE_SIZE)
 834         type = long_integer_type_node;
 835       else if (bits == LONG_LONG_TYPE_SIZE)
 836         type = long_long_integer_type_node;
 837       else
 838         type = build_nonstandard_integer_type (bits,
 839                                                unsignedp);
 840     }
 841   return type;
 842 }
 843
 844 /* Allow the analyzer to understand Storage ALLOCATE/DEALLOCATE.  */
 845
 846 bool
 847 gm2_langhook_new_dispose_storage_substitution (void)
 848 {
 849   return true;
 850 }
 851
 852 #undef LANG_HOOKS_NAME
 853 #undef LANG_HOOKS_INIT
 854 #undef LANG_HOOKS_INIT_OPTIONS
 855 #undef LANG_HOOKS_OPTION_LANG_MASK
 856 #undef LANG_HOOKS_INIT_OPTIONS_STRUCT
 857 #undef LANG_HOOKS_HANDLE_OPTION
 858 #undef LANG_HOOKS_POST_OPTIONS
 859 #undef LANG_HOOKS_PARSE_FILE
 860 #undef LANG_HOOKS_TYPE_FOR_MODE
 861 #undef LANG_HOOKS_TYPE_FOR_SIZE
 862 #undef LANG_HOOKS_BUILTIN_FUNCTION
 863 #undef LANG_HOOKS_GLOBAL_BINDINGS_P
 864 #undef LANG_HOOKS_PUSHDECL
 865 #undef LANG_HOOKS_GETDECLS
 866 #undef LANG_HOOKS_GIMPLIFY_EXPR
 867 #undef LANG_HOOKS_EH_PERSONALITY
 868 #undef LANG_HOOKS_NEW_DISPOSE_STORAGE_SUBSTITUTION
 869
 870 #define LANG_HOOKS_NAME "GNU Modula-2"
 871 #define LANG_HOOKS_INIT gm2_langhook_init
 872 #define LANG_HOOKS_INIT_OPTIONS gm2_langhook_init_options
 873 #define LANG_HOOKS_OPTION_LANG_MASK gm2_langhook_option_lang_mask
 874 #define LANG_HOOKS_INIT_OPTIONS_STRUCT gm2_langhook_init_options_struct
 875 #define LANG_HOOKS_HANDLE_OPTION gm2_langhook_handle_option
 876 #define LANG_HOOKS_POST_OPTIONS gm2_langhook_post_options
 877 #define LANG_HOOKS_PARSE_FILE gm2_langhook_parse_file
 878 #define LANG_HOOKS_TYPE_FOR_MODE gm2_langhook_type_for_mode
 879 #define LANG_HOOKS_TYPE_FOR_SIZE gm2_langhook_type_for_size
 880 #define LANG_HOOKS_BUILTIN_FUNCTION gm2_langhook_builtin_function
 881 #define LANG_HOOKS_GLOBAL_BINDINGS_P gm2_langhook_global_bindings_p
 882 #define LANG_HOOKS_PUSHDECL gm2_langhook_pushdecl
 883 #define LANG_HOOKS_GETDECLS gm2_langhook_getdecls
 884 #define LANG_HOOKS_GIMPLIFY_EXPR gm2_langhook_gimplify_expr
 885 #define LANG_HOOKS_EH_PERSONALITY gm2_langhook_eh_personality
 886 #define LANG_HOOKS_NEW_DISPOSE_STORAGE_SUBSTITUTION \
 887   gm2_langhook_new_dispose_storage_substitution
 888
 889 struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER;
 890
 891 #include "gt-m2-gm2-lang.h"
 892 #include "gtype-m2.h"