2009-06-03 Basile Starynkevitch <basile@starynkevitch.net>

	MELT branch merged with trunk r148111



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/branches/melt-branch@148114 138bc75d-0d04-0410-961f-82ee72b054a4

11 files changed, 441 insertions, 205 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 32c3192d297..533ac20a337 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,64 @@
+2009-06-01  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/40309
+	* trans-decl.c (gfc_sym_identifier): Use "MAIN__" for PROGRAM "main".
+	(create_main_function): Set main_identifier_node.
+
+2009-05-29  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/40019
+	* trans-types.c (gfc_build_uint_type): Make nonstatic.
+	* trans.h (gfor_fndecl_clz128, gfor_fndecl_ctz128): New prototypes.
+	* trans-types.h (gfc_build_uint_type): Add prototype.
+	* trans-decl.c (gfc_build_intrinsic_function_decls): Build
+	gfor_fndecl_clz128 and gfor_fndecl_ctz128.
+	* trans-intrinsic.c (gfc_conv_intrinsic_leadz,
+	gfc_conv_intrinsic_trailz): Call the right builtins or library
+	functions, and cast arguments to unsigned types first.
+	* simplify.c (gfc_simplify_leadz): Deal with negative arguments.
+
+2009-05-27  Ian Lance Taylor  <iant@google.com>
+
+	* Make-lang.in (gfortran$(exeext)): Change $(COMPILER) to
+	$(LINKER).
+	(f951$(exeext)): Likewise.
+
+2009-05-27  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/40270
+	* trans-decl.c (create_main_function): Mark MAIN__ and
+	argc/argv as TREE_USED and push/pop function_decl context
+	if needed.
+
+2009-05-26  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/39178
+	* gfortranspec.c (lang_specific_driver): Stop linking
+	libgfortranbegin.
+	* trans-decl.c (gfc_build_builtin_function_decls): Stop
+	making MAIN__ publicly visible.
+	(gfc_build_builtin_function_decls): Add
+	gfor_fndecl_set_args.
+	(create_main_function) New function.
+	(gfc_generate_function_code): Use it.
+
+2009-05-26  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/40246
+	* match.c (gfc_match_nullify): NULLify freed pointer.
+
+2009-05-26  Ian Lance Taylor  <iant@google.com>
+
+	* Make-lang.in (gfortranspec.o): Use $(COMPILER).
+	(gfortran$(exeext), f951$(exeext), fortran/cpp.o): Likewise.
+
+2009-05-26  Kaveh R. Ghazi  <ghazi@caip.rutgers.edu>
+
+	* gfortran.h (GFC_MPC_RND_MODE): New.
+	* simplify.c (call_mpc_func): New helper function.
+	(gfc_simplify_cos, gfc_simplify_exp, gfc_simplify_log,
+	gfc_simplify_sin, gfc_simplify_sqrt): Add MPC support.
+
 2009-05-25  Janus Weil  <janus@gcc.gnu.org>
 
 	PR fortran/40176
diff --git a/gcc/fortran/Make-lang.in b/gcc/fortran/Make-lang.in
index 5885a621933..0ac9bb2262b 100644
--- a/gcc/fortran/Make-lang.in
+++ b/gcc/fortran/Make-lang.in
@@ -1,6 +1,6 @@
 # -*- makefile -*-
 # Top level makefile fragment for GNU gfortran, the GNU Fortran 95 compiler.
-# Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software
+# Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 Free Software
 # Foundation, Inc.
 # Contributed by Paul Brook <paul@nowt.org
 # and Steven Bosscher <s.bosscher@student.tudelft.nl>
@@ -80,13 +80,13 @@ fortran: f951$(exeext)
 gfortranspec.o: $(srcdir)/fortran/gfortranspec.c $(SYSTEM_H) $(TM_H) $(GCC_H) \
 	$(CONFIG_H) coretypes.h intl.h
 	(SHLIB_LINK='$(SHLIB_LINK)'; \
-	$(CC) -c $(ALL_CFLAGS) $(ALL_CPPFLAGS) $(DRIVER_DEFINES) \
+	$(COMPILER) -c $(ALL_COMPILERFLAGS) $(ALL_CPPFLAGS) $(DRIVER_DEFINES) \
 		$(INCLUDES) $(srcdir)/fortran/gfortranspec.c)
 
 # Create the compiler driver gfortran.
 GFORTRAN_D_OBJS = $(GCC_OBJS) gfortranspec.o version.o prefix.o intl.o
 gfortran$(exeext): $(GFORTRAN_D_OBJS) $(EXTRA_GCC_OBJS) $(LIBDEPS)
-	$(CC) $(ALL_CFLAGS) $(LDFLAGS) -o $@ \
+	$(LINKER) $(ALL_LINKERFLAGS) $(LDFLAGS) -o $@ \
 	  $(GFORTRAN_D_OBJS) $(EXTRA_GCC_OBJS) $(LIBS)
 
 # Create a version of the gfortran driver which calls the cross-compiler.
@@ -97,7 +97,7 @@ gfortran-cross$(exeext): gfortran$(exeext)
 # The compiler itself is called f951.
 f951$(exeext): $(F95_OBJS) \
 		$(BACKEND) $(LIBDEPS) attribs.o
-	$(CC) $(ALL_CFLAGS) $(LDFLAGS) -o $@ \
+	$(LINKER) $(ALL_LINKERFLAGS) $(LDFLAGS) -o $@ \
 		$(F95_OBJS) $(BACKEND) $(LIBS) attribs.o $(BACKENDLIBS)
 
 gt-fortran-trans.h    : s-gtype; @true
@@ -338,5 +338,5 @@ fortran/resolve.o: fortran/dependency.h fortran/data.h fortran/target-memory.h
 fortran/data.o: fortran/data.h
 fortran/options.o: $(PARAMS_H) $(TARGET_H) fortran/cpp.h
 fortran/cpp.o: fortran/cpp.c $(BASEVER) incpath.h incpath.o
-	$(CC) -c $(ALL_CFLAGS) $(ALL_CPPFLAGS) -DBASEVER=$(BASEVER_s) \
-		$< $(OUTPUT_OPTION)
+	$(COMPILER) -c $(ALL_COMPILERFLAGS) $(ALL_CPPFLAGS) \
+		-DBASEVER=$(BASEVER_s) $< $(OUTPUT_OPTION)
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 8ed05f2d6dd..82f07ef0052 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -1556,6 +1556,7 @@ gfc_intrinsic_sym;
 #include <gmp.h>
 #include <mpfr.h>
 #define GFC_RND_MODE GMP_RNDN
+#define GFC_MPC_RND_MODE MPC_RNDNN
 
 typedef struct gfc_expr
 {
diff --git a/gcc/fortran/gfortranspec.c b/gcc/fortran/gfortranspec.c
index 0e5e7913e97..a6f9b42b474 100644
--- a/gcc/fortran/gfortranspec.c
+++ b/gcc/fortran/gfortranspec.c
@@ -58,10 +58,6 @@ along with GCC; see the file COPYING3.  If not see
 #define MATH_LIBRARY "-lm"
 #endif
 
-#ifndef FORTRAN_INIT
-#define FORTRAN_INIT "-lgfortranbegin"
-#endif
-
 #ifndef FORTRAN_LIBRARY
 #define FORTRAN_LIBRARY "-lgfortran"
 #endif
@@ -278,10 +274,6 @@ lang_specific_driver (int *in_argc, const char *const **in_argv,
      2 => last two args were -l<library> -lm.  */
   int saw_library = 0;
 
-  /* 0 => initial/reset state
-     1 => FORTRAN_INIT linked in */
-  int use_init = 0;
-
   /* By default, we throw on the math library if we have one.  */
   int need_math = (MATH_LIBRARY[0] != '\0');
 
@@ -505,12 +497,6 @@ For more information about these matters, see the file named COPYING\n\n"));
 		saw_library = 2;	/* -l<library> -lm.  */
 	      else
 		{
-		  if (0 == use_init)
-		    {
-		      append_arg (FORTRAN_INIT);
-		      use_init = 1;
-		    }
-
 		  ADD_ARG_LIBGFORTRAN (FORTRAN_LIBRARY);
 		}
 	    }
@@ -540,11 +526,6 @@ For more information about these matters, see the file named COPYING\n\n"));
       switch (saw_library)
 	{
 	case 0:
-	  if (0 == use_init)
-	    {
-	      append_arg (FORTRAN_INIT);
-	      use_init = 1;
-	    }
 	  ADD_ARG_LIBGFORTRAN (library);
 	  /* Fall through.  */
 
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index ed7bf58bb86..cf558b54e1b 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -2418,6 +2418,11 @@ syntax:
 
 cleanup:
   gfc_free_statements (new_st.next);
+  new_st.next = NULL;
+  gfc_free_expr (new_st.expr1);
+  new_st.expr1 = NULL;
+  gfc_free_expr (new_st.expr2);
+  new_st.expr2 = NULL;
   return MATCH_ERROR;
 }
 
diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index 01b252cf2ad..51a3c5198e5 100644
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -210,6 +210,24 @@ convert_mpz_to_signed (mpz_t x, int bitsize)
     }
 }
 
+/* Helper function to convert to/from mpfr_t & mpc_t and call the
+   supplied mpc function on the respective values.  */
+
+#ifdef HAVE_mpc
+static void
+call_mpc_func (mpfr_ptr result_re, mpfr_ptr result_im,
+	       mpfr_srcptr input_re, mpfr_srcptr input_im,
+	       int (*func)(mpc_ptr, mpc_srcptr, mpc_rnd_t))
+{
+  mpc_t c;
+  mpc_init2 (c, mpfr_get_default_prec());
+  mpc_set_fr_fr (c, input_re, input_im, GFC_MPC_RND_MODE);
+  func (c, c, GFC_MPC_RND_MODE);
+  mpfr_set (result_re, MPC_RE (c), GFC_RND_MODE);
+  mpfr_set (result_im, MPC_IM (c), GFC_RND_MODE);
+  mpc_clear (c);
+}
+#endif
 
 /********************** Simplification functions *****************************/
 
@@ -985,7 +1003,6 @@ gfc_expr *
 gfc_simplify_cos (gfc_expr *x)
 {
   gfc_expr *result;
-  mpfr_t xp, xq;
 
   if (x->expr_type != EXPR_CONSTANT)
     return NULL;
@@ -999,6 +1016,12 @@ gfc_simplify_cos (gfc_expr *x)
       break;
     case BT_COMPLEX:
       gfc_set_model_kind (x->ts.kind);
+#ifdef HAVE_mpc
+      call_mpc_func (result->value.complex.r, result->value.complex.i,
+		     x->value.complex.r, x->value.complex.i, mpc_cos);
+#else
+    {
+      mpfr_t xp, xq;
       mpfr_init (xp);
       mpfr_init (xq);
 
@@ -1012,6 +1035,8 @@ gfc_simplify_cos (gfc_expr *x)
       mpfr_neg (result->value.complex.i, xp, GFC_RND_MODE );
 
       mpfr_clears (xp, xq, NULL);
+    }
+#endif
       break;
     default:
       gfc_internal_error ("in gfc_simplify_cos(): Bad type");
@@ -1370,7 +1395,6 @@ gfc_expr *
 gfc_simplify_exp (gfc_expr *x)
 {
   gfc_expr *result;
-  mpfr_t xp, xq;
 
   if (x->expr_type != EXPR_CONSTANT)
     return NULL;
@@ -1385,6 +1409,12 @@ gfc_simplify_exp (gfc_expr *x)
 
     case BT_COMPLEX:
       gfc_set_model_kind (x->ts.kind);
+#ifdef HAVE_mpc
+      call_mpc_func (result->value.complex.r, result->value.complex.i,
+		     x->value.complex.r, x->value.complex.i, mpc_exp);
+#else
+    {
+      mpfr_t xp, xq;
       mpfr_init (xp);
       mpfr_init (xq);
       mpfr_exp (xq, x->value.complex.r, GFC_RND_MODE);
@@ -1393,6 +1423,8 @@ gfc_simplify_exp (gfc_expr *x)
       mpfr_sin (xp, x->value.complex.i, GFC_RND_MODE);
       mpfr_mul (result->value.complex.i, xq, xp, GFC_RND_MODE);
       mpfr_clears (xp, xq, NULL);
+    }
+#endif
       break;
 
     default:
@@ -2547,10 +2579,13 @@ gfc_simplify_leadz (gfc_expr *e)
   bs = gfc_integer_kinds[i].bit_size;
   if (mpz_cmp_si (e->value.integer, 0) == 0)
     lz = bs;
+  else if (mpz_cmp_si (e->value.integer, 0) < 0)
+    lz = 0;
   else
     lz = bs - mpz_sizeinbase (e->value.integer, 2);
 
-  result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind, &e->where);
+  result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
+				&e->where);
   mpz_set_ui (result->value.integer, lz);
 
   return result;
@@ -2688,7 +2723,6 @@ gfc_expr *
 gfc_simplify_log (gfc_expr *x)
 {
   gfc_expr *result;
-  mpfr_t xr, xi;
 
   if (x->expr_type != EXPR_CONSTANT)
     return NULL;
@@ -2721,6 +2755,12 @@ gfc_simplify_log (gfc_expr *x)
 	}
 
       gfc_set_model_kind (x->ts.kind);
+#ifdef HAVE_mpc
+      call_mpc_func (result->value.complex.r, result->value.complex.i,
+		     x->value.complex.r, x->value.complex.i, mpc_log);
+#else
+    {
+      mpfr_t xr, xi;
       mpfr_init (xr);
       mpfr_init (xi);
 
@@ -2734,7 +2774,8 @@ gfc_simplify_log (gfc_expr *x)
       mpfr_log (result->value.complex.r, xr, GFC_RND_MODE);
 
       mpfr_clears (xr, xi, NULL);
-
+    }
+#endif
       break;
 
     default:
@@ -4314,7 +4355,6 @@ gfc_expr *
 gfc_simplify_sin (gfc_expr *x)
 {
   gfc_expr *result;
-  mpfr_t xp, xq;
 
   if (x->expr_type != EXPR_CONSTANT)
     return NULL;
@@ -4329,6 +4369,12 @@ gfc_simplify_sin (gfc_expr *x)
 
     case BT_COMPLEX:
       gfc_set_model (x->value.real);
+#ifdef HAVE_mpc
+      call_mpc_func (result->value.complex.r, result->value.complex.i,
+		     x->value.complex.r, x->value.complex.i, mpc_sin);
+#else
+    {
+      mpfr_t xp, xq;
       mpfr_init (xp);
       mpfr_init (xq);
 
@@ -4341,6 +4387,8 @@ gfc_simplify_sin (gfc_expr *x)
       mpfr_mul (result->value.complex.i, xp, xq, GFC_RND_MODE);
 
       mpfr_clears (xp, xq, NULL);
+    }
+#endif
       break;
 
     default:
@@ -4425,7 +4473,6 @@ gfc_expr *
 gfc_simplify_sqrt (gfc_expr *e)
 {
   gfc_expr *result;
-  mpfr_t ac, ad, s, t, w;
 
   if (e->expr_type != EXPR_CONSTANT)
     return NULL;
@@ -4442,10 +4489,16 @@ gfc_simplify_sqrt (gfc_expr *e)
       break;
 
     case BT_COMPLEX:
+      gfc_set_model (e->value.real);
+#ifdef HAVE_mpc
+      call_mpc_func (result->value.complex.r, result->value.complex.i,
+		     e->value.complex.r, e->value.complex.i, mpc_sqrt);
+#else
+    {
       /* Formula taken from Numerical Recipes to avoid over- and
 	 underflow.  */
 
-      gfc_set_model (e->value.real);
+      mpfr_t ac, ad, s, t, w;
       mpfr_init (ac);
       mpfr_init (ad);
       mpfr_init (s);
@@ -4517,7 +4570,8 @@ gfc_simplify_sqrt (gfc_expr *e)
 			    &e->where);
 
       mpfr_clears (s, t, ac, ad, w, NULL);
-
+    }
+#endif
       break;
 
     default:
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 8f355f6a373..ef6172c85c3 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -86,6 +86,7 @@ tree gfor_fndecl_runtime_error_at;
 tree gfor_fndecl_runtime_warning_at;
 tree gfor_fndecl_os_error;
 tree gfor_fndecl_generate_error;
+tree gfor_fndecl_set_args;
 tree gfor_fndecl_set_fpe;
 tree gfor_fndecl_set_options;
 tree gfor_fndecl_set_convert;
@@ -144,6 +145,8 @@ tree gfor_fndecl_convert_char4_to_char1;
 tree gfor_fndecl_size0;
 tree gfor_fndecl_size1;
 tree gfor_fndecl_iargc;
+tree gfor_fndecl_clz128;
+tree gfor_fndecl_ctz128;
 
 /* Intrinsic functions implemented in Fortran.  */
 tree gfor_fndecl_sc_kind;
@@ -286,7 +289,10 @@ gfc_get_label_decl (gfc_st_label * lp)
 static tree
 gfc_sym_identifier (gfc_symbol * sym)
 {
-  return (get_identifier (sym->name));
+  if (sym->attr.is_main_program && strcmp (sym->name, "main") == 0)
+    return (get_identifier ("MAIN__"));
+  else
+    return (get_identifier (sym->name));
 }
 
 
@@ -1525,7 +1531,7 @@ build_function_decl (gfc_symbol * sym)
   /* This specifies if a function is globally visible, i.e. it is
      the opposite of declaring static in C.  */
   if (DECL_CONTEXT (fndecl) == NULL_TREE
-      && !sym->attr.entry_master)
+      && !sym->attr.entry_master && !sym->attr.is_main_program)
     TREE_PUBLIC (fndecl) = 1;
 
   /* TREE_STATIC means the function body is defined here.  */
@@ -1544,12 +1550,6 @@ build_function_decl (gfc_symbol * sym)
       TREE_SIDE_EFFECTS (fndecl) = 0;
     }
 
-  /* For -fwhole-program to work well, the main program needs to have the
-     "externally_visible" attribute.  */
-  if (attr.is_main_program)
-    DECL_ATTRIBUTES (fndecl)
-      = tree_cons (get_identifier("externally_visible"), NULL_TREE, NULL_TREE);
-
   /* Layout the function declaration and put it in the binding level
      of the current function.  */
   pushdecl (fndecl);
@@ -2575,6 +2575,19 @@ gfc_build_intrinsic_function_decls (void)
     gfc_build_library_function_decl (get_identifier (PREFIX ("iargc")),
 				     gfc_int4_type_node,
 				     0);
+
+  if (gfc_type_for_size (128, true))
+    {
+      tree uint128 = gfc_type_for_size (128, true);
+
+      gfor_fndecl_clz128 =
+	gfc_build_library_function_decl (get_identifier (PREFIX ("clz128")),
+					 integer_type_node, 1, uint128);
+
+      gfor_fndecl_ctz128 =
+	gfc_build_library_function_decl (get_identifier (PREFIX ("ctz128")),
+					 integer_type_node, 1, uint128);
+    }
 }
 
 
@@ -2635,6 +2648,11 @@ gfc_build_builtin_function_decls (void)
   /* The runtime_error function does not return.  */
   TREE_THIS_VOLATILE (gfor_fndecl_os_error) = 1;
 
+  gfor_fndecl_set_args =
+    gfc_build_library_function_decl (get_identifier (PREFIX("set_args")),
+				     void_type_node, 2, integer_type_node,
+				     build_pointer_type (pchar_type_node));
+
   gfor_fndecl_set_fpe =
     gfc_build_library_function_decl (get_identifier (PREFIX("set_fpe")),
 				    void_type_node, 1, integer_type_node);
@@ -2643,7 +2661,7 @@ gfc_build_builtin_function_decls (void)
   gfor_fndecl_set_options =
     gfc_build_library_function_decl (get_identifier (PREFIX("set_options")),
 				    void_type_node, 2, integer_type_node,
-				    pvoid_type_node);
+				    build_pointer_type (integer_type_node));
 
   gfor_fndecl_set_convert =
     gfc_build_library_function_decl (get_identifier (PREFIX("set_convert")),
@@ -3835,6 +3853,220 @@ add_argument_checking (stmtblock_t *block, gfc_symbol *sym)
 }
 
 
+static void
+create_main_function (tree fndecl)
+{
+  tree old_context;
+  tree ftn_main;
+  tree tmp, decl, result_decl, argc, argv, typelist, arglist;
+  stmtblock_t body;
+
+  old_context = current_function_decl;
+
+  if (old_context)
+    {
+      push_function_context ();
+      saved_parent_function_decls = saved_function_decls;
+      saved_function_decls = NULL_TREE;
+    }
+
+  /* main() function must be declared with global scope.  */
+  gcc_assert (current_function_decl == NULL_TREE);
+
+  /* Declare the function.  */
+  tmp =  build_function_type_list (integer_type_node, integer_type_node,
+				   build_pointer_type (pchar_type_node),
+				   NULL_TREE);
+  main_identifier_node = get_identifier ("main");
+  ftn_main = build_decl (FUNCTION_DECL, main_identifier_node, tmp);
+  ftn_main = build_decl (FUNCTION_DECL, get_identifier ("main"), tmp);
+  DECL_EXTERNAL (ftn_main) = 0;
+  TREE_PUBLIC (ftn_main) = 1;
+  TREE_STATIC (ftn_main) = 1;
+  DECL_ATTRIBUTES (ftn_main)
+      = tree_cons (get_identifier("externally_visible"), NULL_TREE, NULL_TREE);
+
+  /* Setup the result declaration (for "return 0").  */
+  result_decl = build_decl (RESULT_DECL, NULL_TREE, integer_type_node);
+  DECL_ARTIFICIAL (result_decl) = 1;
+  DECL_IGNORED_P (result_decl) = 1;
+  DECL_CONTEXT (result_decl) = ftn_main;
+  DECL_RESULT (ftn_main) = result_decl;
+
+  pushdecl (ftn_main);
+
+  /* Get the arguments.  */
+
+  arglist = NULL_TREE;
+  typelist = TYPE_ARG_TYPES (TREE_TYPE (ftn_main));
+
+  tmp = TREE_VALUE (typelist);
+  argc = build_decl (PARM_DECL, get_identifier ("argc"), tmp);
+  DECL_CONTEXT (argc) = ftn_main;
+  DECL_ARG_TYPE (argc) = TREE_VALUE (typelist);
+  TREE_READONLY (argc) = 1;
+  gfc_finish_decl (argc);
+  arglist = chainon (arglist, argc);
+
+  typelist = TREE_CHAIN (typelist);
+  tmp = TREE_VALUE (typelist);
+  argv = build_decl (PARM_DECL, get_identifier ("argv"), tmp);
+  DECL_CONTEXT (argv) = ftn_main;
+  DECL_ARG_TYPE (argv) = TREE_VALUE (typelist);
+  TREE_READONLY (argv) = 1;
+  DECL_BY_REFERENCE (argv) = 1;
+  gfc_finish_decl (argv);
+  arglist = chainon (arglist, argv);
+
+  DECL_ARGUMENTS (ftn_main) = arglist;
+  current_function_decl = ftn_main;
+  announce_function (ftn_main);
+
+  rest_of_decl_compilation (ftn_main, 1, 0);
+  make_decl_rtl (ftn_main);
+  init_function_start (ftn_main);
+  pushlevel (0);
+
+  gfc_init_block (&body);
+
+  /* Call some libgfortran initialization routines, call then MAIN__(). */
+
+  /* Call _gfortran_set_args (argc, argv).  */
+  TREE_USED (argc) = 1;
+  TREE_USED (argv) = 1;
+  tmp = build_call_expr (gfor_fndecl_set_args, 2, argc, argv);
+  gfc_add_expr_to_block (&body, tmp);
+
+  /* Add a call to set_options to set up the runtime library Fortran
+     language standard parameters.  */
+  {
+    tree array_type, array, var;
+
+    /* Passing a new option to the library requires four modifications:
+     + add it to the tree_cons list below
+          + change the array size in the call to build_array_type
+          + change the first argument to the library call
+            gfor_fndecl_set_options
+          + modify the library (runtime/compile_options.c)!  */
+
+    array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
+		       gfc_option.warn_std), NULL_TREE);
+    array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
+		       gfc_option.allow_std), array);
+    array = tree_cons (NULL_TREE, build_int_cst (integer_type_node, pedantic),
+		       array);
+    array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
+		       gfc_option.flag_dump_core), array);
+    array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
+		       gfc_option.flag_backtrace), array);
+    array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
+		       gfc_option.flag_sign_zero), array);
+
+    array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
+		       (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)), array);
+
+    array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
+		       gfc_option.flag_range_check), array);
+
+    array_type = build_array_type (integer_type_node,
+		       build_index_type (build_int_cst (NULL_TREE, 7)));
+    array = build_constructor_from_list (array_type, nreverse (array));
+    TREE_CONSTANT (array) = 1;
+    TREE_STATIC (array) = 1;
+
+    /* Create a static variable to hold the jump table.  */
+    var = gfc_create_var (array_type, "options");
+    TREE_CONSTANT (var) = 1;
+    TREE_STATIC (var) = 1;
+    TREE_READONLY (var) = 1;
+    DECL_INITIAL (var) = array;
+    var = gfc_build_addr_expr (build_pointer_type (integer_type_node), var);
+
+    tmp = build_call_expr (gfor_fndecl_set_options, 2,
+			   build_int_cst (integer_type_node, 8), var);
+    gfc_add_expr_to_block (&body, tmp);
+  }
+
+  /* If -ffpe-trap option was provided, add a call to set_fpe so that
+     the library will raise a FPE when needed.  */
+  if (gfc_option.fpe != 0)
+    {
+      tmp = build_call_expr (gfor_fndecl_set_fpe, 1,
+			     build_int_cst (integer_type_node,
+					    gfc_option.fpe));
+      gfc_add_expr_to_block (&body, tmp);
+    }
+
+  /* If this is the main program and an -fconvert option was provided,
+     add a call to set_convert.  */
+
+  if (gfc_option.convert != GFC_CONVERT_NATIVE)
+    {
+      tmp = build_call_expr (gfor_fndecl_set_convert, 1,
+			     build_int_cst (integer_type_node,
+					    gfc_option.convert));
+      gfc_add_expr_to_block (&body, tmp);
+    }
+
+  /* If this is the main program and an -frecord-marker option was provided,
+     add a call to set_record_marker.  */
+
+  if (gfc_option.record_marker != 0)
+    {
+      tmp = build_call_expr (gfor_fndecl_set_record_marker, 1,
+			     build_int_cst (integer_type_node,
+					    gfc_option.record_marker));
+      gfc_add_expr_to_block (&body, tmp);
+    }
+
+  if (gfc_option.max_subrecord_length != 0)
+    {
+      tmp = build_call_expr (gfor_fndecl_set_max_subrecord_length, 1,
+			     build_int_cst (integer_type_node,
+					    gfc_option.max_subrecord_length));
+      gfc_add_expr_to_block (&body, tmp);
+    }
+
+  /* Call MAIN__().  */
+  tmp = build_call_expr (fndecl, 0);
+  gfc_add_expr_to_block (&body, tmp);
+
+  /* Mark MAIN__ as used.  */
+  TREE_USED (fndecl) = 1;
+
+  /* "return 0".  */
+  tmp = fold_build2 (MODIFY_EXPR, integer_type_node, DECL_RESULT (ftn_main),
+		     build_int_cst (integer_type_node, 0));
+  tmp = build1_v (RETURN_EXPR, tmp);
+  gfc_add_expr_to_block (&body, tmp);
+
+
+  DECL_SAVED_TREE (ftn_main) = gfc_finish_block (&body);
+  decl = getdecls ();
+
+  /* Finish off this function and send it for code generation.  */
+  poplevel (1, 0, 1);
+  BLOCK_SUPERCONTEXT (DECL_INITIAL (ftn_main)) = ftn_main;
+
+  DECL_SAVED_TREE (ftn_main)
+    = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (ftn_main),
+		DECL_INITIAL (ftn_main));
+
+  /* Output the GENERIC tree.  */
+  dump_function (TDI_original, ftn_main);
+
+  gfc_gimplify_function (ftn_main);
+  cgraph_finalize_function (ftn_main, false);
+
+  if (old_context)
+    {
+      pop_function_context ();
+      saved_function_decls = saved_parent_function_decls;
+    }
+  current_function_decl = old_context;
+}
+
+
 /* Generate code for a function.  */
 
 void
@@ -3919,107 +4151,6 @@ gfc_generate_function_code (gfc_namespace * ns)
   /* Now generate the code for the body of this function.  */
   gfc_init_block (&body);
 
-  /* If this is the main program, add a call to set_options to set up the
-     runtime library Fortran language standard parameters.  */
-  if (sym->attr.is_main_program)
-    {
-      tree array_type, array, var;
-
-      /* Passing a new option to the library requires four modifications:
-	   + add it to the tree_cons list below
-	   + change the array size in the call to build_array_type
-	   + change the first argument to the library call
-	     gfor_fndecl_set_options
-	   + modify the library (runtime/compile_options.c)!  */
-      array = tree_cons (NULL_TREE,
-			 build_int_cst (integer_type_node,
-					gfc_option.warn_std), NULL_TREE);
-      array = tree_cons (NULL_TREE,
-			 build_int_cst (integer_type_node,
-					gfc_option.allow_std), array);
-      array = tree_cons (NULL_TREE,
-			 build_int_cst (integer_type_node, pedantic), array);
-      array = tree_cons (NULL_TREE,
-			 build_int_cst (integer_type_node,
-					gfc_option.flag_dump_core), array);
-      array = tree_cons (NULL_TREE,
-			 build_int_cst (integer_type_node,
-					gfc_option.flag_backtrace), array);
-      array = tree_cons (NULL_TREE,
-			 build_int_cst (integer_type_node,
-					gfc_option.flag_sign_zero), array);
-
-      array = tree_cons (NULL_TREE,
-			 build_int_cst (integer_type_node,
-					(gfc_option.rtcheck
-					 & GFC_RTCHECK_BOUNDS)), array);
-
-      array = tree_cons (NULL_TREE,
-			 build_int_cst (integer_type_node,
-					gfc_option.flag_range_check), array);
-
-      array_type = build_array_type (integer_type_node,
-				     build_index_type (build_int_cst (NULL_TREE,
-								      7)));
-      array = build_constructor_from_list (array_type, nreverse (array));
-      TREE_CONSTANT (array) = 1;
-      TREE_STATIC (array) = 1;
-
-      /* Create a static variable to hold the jump table.  */
-      var = gfc_create_var (array_type, "options");
-      TREE_CONSTANT (var) = 1;
-      TREE_STATIC (var) = 1;
-      TREE_READONLY (var) = 1;
-      DECL_INITIAL (var) = array;
-      var = gfc_build_addr_expr (pvoid_type_node, var);
-
-      tmp = build_call_expr (gfor_fndecl_set_options, 2,
-			     build_int_cst (integer_type_node, 8), var);
-      gfc_add_expr_to_block (&body, tmp);
-    }
-
-  /* If this is the main program and a -ffpe-trap option was provided,
-     add a call to set_fpe so that the library will raise a FPE when
-     needed.  */
-  if (sym->attr.is_main_program && gfc_option.fpe != 0)
-    {
-      tmp = build_call_expr (gfor_fndecl_set_fpe, 1,
-			     build_int_cst (integer_type_node,
-					    gfc_option.fpe));
-      gfc_add_expr_to_block (&body, tmp);
-    }
-
-  /* If this is the main program and an -fconvert option was provided,
-     add a call to set_convert.  */
-
-  if (sym->attr.is_main_program && gfc_option.convert != GFC_CONVERT_NATIVE)
-    {
-      tmp = build_call_expr (gfor_fndecl_set_convert, 1,
-			     build_int_cst (integer_type_node,
-					    gfc_option.convert));
-      gfc_add_expr_to_block (&body, tmp);
-    }
-
-  /* If this is the main program and an -frecord-marker option was provided,
-     add a call to set_record_marker.  */
-
-  if (sym->attr.is_main_program && gfc_option.record_marker != 0)
-    {
-      tmp = build_call_expr (gfor_fndecl_set_record_marker, 1,
-			     build_int_cst (integer_type_node,
-					    gfc_option.record_marker));
-      gfc_add_expr_to_block (&body, tmp);
-    }
-
-  if (sym->attr.is_main_program && gfc_option.max_subrecord_length != 0)
-    {
-      tmp = build_call_expr (gfor_fndecl_set_max_subrecord_length,
-			     1,
-			     build_int_cst (integer_type_node,
-					    gfc_option.max_subrecord_length));
-      gfc_add_expr_to_block (&body, tmp);
-    }
-
    is_recursive = sym->attr.recursive
 		  || (sym->attr.entry_master
 		      && sym->ns->entries->sym->attr.recursive);
@@ -4203,8 +4334,12 @@ gfc_generate_function_code (gfc_namespace * ns)
 
   gfc_trans_use_stmts (ns);
   gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
+
+  if (sym->attr.is_main_program)
+    create_main_function (fndecl);
 }
 
+
 void
 gfc_generate_constructors (void)
 {
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 33cc7f569a3..c1409578610 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -2710,53 +2710,51 @@ gfc_conv_intrinsic_leadz (gfc_se * se, gfc_expr * expr)
   tree leadz;
   tree bit_size;
   tree tmp;
-  int arg_kind;
-  int i, n, s;
+  tree func;
+  int s, argsize;
 
   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
+  argsize = TYPE_PRECISION (TREE_TYPE (arg));
 
   /* Which variant of __builtin_clz* should we call?  */
-  arg_kind = expr->value.function.actual->expr->ts.kind;
-  i = gfc_validate_kind (BT_INTEGER, arg_kind, false);
-  switch (arg_kind)
+  if (argsize <= INT_TYPE_SIZE)
     {
-      case 1:
-      case 2:
-      case 4:
-        arg_type = unsigned_type_node;
-	n = BUILT_IN_CLZ;
-	break;
-
-      case 8:
-        arg_type = long_unsigned_type_node;
-	n = BUILT_IN_CLZL;
-	break;
-
-      case 16:
-        arg_type = long_long_unsigned_type_node;
-	n = BUILT_IN_CLZLL;
-	break;
-
-      default:
-        gcc_unreachable ();
+      arg_type = unsigned_type_node;
+      func = built_in_decls[BUILT_IN_CLZ];
+    }
+  else if (argsize <= LONG_TYPE_SIZE)
+    {
+      arg_type = long_unsigned_type_node;
+      func = built_in_decls[BUILT_IN_CLZL];
+    }
+  else if (argsize <= LONG_LONG_TYPE_SIZE)
+    {
+      arg_type = long_long_unsigned_type_node;
+      func = built_in_decls[BUILT_IN_CLZLL];
+    }
+  else
+    {
+      gcc_assert (argsize == 128);
+      arg_type = gfc_build_uint_type (argsize);
+      func = gfor_fndecl_clz128;
     }
 
-  /* Convert the actual argument to the proper argument type for the built-in
+  /* Convert the actual argument twice: first, to the unsigned type of the
+     same size; then, to the proper argument type for the built-in
      function.  But the return type is of the default INTEGER kind.  */
+  arg = fold_convert (gfc_build_uint_type (argsize), arg);
   arg = fold_convert (arg_type, arg);
   result_type = gfc_get_int_type (gfc_default_integer_kind);
 
   /* Compute LEADZ for the case i .ne. 0.  */
-  s = TYPE_PRECISION (arg_type) - gfc_integer_kinds[i].bit_size;
-  tmp = fold_convert (result_type, build_call_expr (built_in_decls[n], 1, arg));
+  s = TYPE_PRECISION (arg_type) - argsize;
+  tmp = fold_convert (result_type, build_call_expr (func, 1, arg));
   leadz = fold_build2 (MINUS_EXPR, result_type,
 		       tmp, build_int_cst (result_type, s));
 
   /* Build BIT_SIZE.  */
-  bit_size = build_int_cst (result_type, gfc_integer_kinds[i].bit_size);
+  bit_size = build_int_cst (result_type, argsize);
 
-  /* ??? For some combinations of targets and integer kinds, the condition
-	 can be avoided if CLZ_DEFINED_VALUE_AT_ZERO is used.  Later.  */
   cond = fold_build2 (EQ_EXPR, boolean_type_node,
 		      arg, build_int_cst (arg_type, 0));
   se->expr = fold_build3 (COND_EXPR, result_type, cond, bit_size, leadz);
@@ -2777,50 +2775,48 @@ gfc_conv_intrinsic_trailz (gfc_se * se, gfc_expr *expr)
   tree result_type;
   tree trailz;
   tree bit_size;
-  int arg_kind;
-  int i, n;
+  tree func;
+  int argsize;
 
   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
+  argsize = TYPE_PRECISION (TREE_TYPE (arg));
 
-  /* Which variant of __builtin_clz* should we call?  */
-  arg_kind = expr->value.function.actual->expr->ts.kind;
-  i = gfc_validate_kind (BT_INTEGER, arg_kind, false);
-  switch (expr->ts.kind)
+  /* Which variant of __builtin_ctz* should we call?  */
+  if (argsize <= INT_TYPE_SIZE)
     {
-      case 1:
-      case 2:
-      case 4:
-        arg_type = unsigned_type_node;
-	n = BUILT_IN_CTZ;
-	break;
-
-      case 8:
-        arg_type = long_unsigned_type_node;
-	n = BUILT_IN_CTZL;
-	break;
-
-      case 16:
-        arg_type = long_long_unsigned_type_node;
-	n = BUILT_IN_CTZLL;
-	break;
-
-      default:
-        gcc_unreachable ();
+      arg_type = unsigned_type_node;
+      func = built_in_decls[BUILT_IN_CTZ];
+    }
+  else if (argsize <= LONG_TYPE_SIZE)
+    {
+      arg_type = long_unsigned_type_node;
+      func = built_in_decls[BUILT_IN_CTZL];
+    }
+  else if (argsize <= LONG_LONG_TYPE_SIZE)
+    {
+      arg_type = long_long_unsigned_type_node;
+      func = built_in_decls[BUILT_IN_CTZLL];
+    }
+  else
+    {
+      gcc_assert (argsize == 128);
+      arg_type = gfc_build_uint_type (argsize);
+      func = gfor_fndecl_ctz128;
     }
 
-  /* Convert the actual argument to the proper argument type for the built-in
+  /* Convert the actual argument twice: first, to the unsigned type of the
+     same size; then, to the proper argument type for the built-in
      function.  But the return type is of the default INTEGER kind.  */
+  arg = fold_convert (gfc_build_uint_type (argsize), arg);
   arg = fold_convert (arg_type, arg);
   result_type = gfc_get_int_type (gfc_default_integer_kind);
 
   /* Compute TRAILZ for the case i .ne. 0.  */
-  trailz = fold_convert (result_type, build_call_expr (built_in_decls[n], 1, arg));
+  trailz = fold_convert (result_type, build_call_expr (func, 1, arg));
 
   /* Build BIT_SIZE.  */
-  bit_size = build_int_cst (result_type, gfc_integer_kinds[i].bit_size);
+  bit_size = build_int_cst (result_type, argsize);
 
-  /* ??? For some combinations of targets and integer kinds, the condition
-	 can be avoided if CTZ_DEFINED_VALUE_AT_ZERO is used.  Later.  */
   cond = fold_build2 (EQ_EXPR, boolean_type_node,
 		      arg, build_int_cst (arg_type, 0));
   se->expr = fold_build3 (COND_EXPR, result_type, cond, bit_size, trailz);
diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index e945fcbf7b5..0c439937125 100644
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -686,7 +686,7 @@ gfc_build_int_type (gfc_integer_info *info)
   return make_signed_type (mode_precision);
 }
 
-static tree
+tree
 gfc_build_uint_type (int size)
 {
   if (size == CHAR_TYPE_SIZE)
diff --git a/gcc/fortran/trans-types.h b/gcc/fortran/trans-types.h
index c3e51a11c8e..283d57772a0 100644
--- a/gcc/fortran/trans-types.h
+++ b/gcc/fortran/trans-types.h
@@ -68,6 +68,7 @@ tree gfc_get_function_type (gfc_symbol *);
 
 tree gfc_type_for_size (unsigned, int);
 tree gfc_type_for_mode (enum machine_mode, int);
+tree gfc_build_uint_type (int);
 
 tree gfc_get_element_type (tree);
 tree gfc_get_array_type_bounds (tree, int, tree *, tree *, int,
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 4846af245fd..906896985d1 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -590,6 +590,8 @@ extern GTY(()) tree gfor_fndecl_convert_char4_to_char1;
 extern GTY(()) tree gfor_fndecl_size0;
 extern GTY(()) tree gfor_fndecl_size1;
 extern GTY(()) tree gfor_fndecl_iargc;
+extern GTY(()) tree gfor_fndecl_clz128;
+extern GTY(()) tree gfor_fndecl_ctz128;
 
 /* Implemented in Fortran.  */
 extern GTY(()) tree gfor_fndecl_sc_kind;