Make the Fortran front-end use garbage collection:

	* com.c (ffecom_init_0): Make double_ftype_double,
	float_ftype_float, ldouble_ftype_ldouble,
	ffecom_tree_ptr_to_fun_type_void local.
	(tracker_head): New static variable.
	(mark_tracker_head): New, marker procedure for tracker_head.
	(ffecom_save_tree_forever): New procedure.
	(ffecom_init_zero_): Remove obstack use.
	(ffecom_make_gfrt_): Remove obstack use.
	(ffecom_sym_transform_): Remove obstack use, save appropriate trees.
	(ffecom_transform_common_): Remove obstack use, save appropriate
	trees.
	(ffecom_type_namelist_): Remove obstack use, save appropriate
	trees.
	(ffecom_type_vardesc_): Remove obstack use, save appropriate trees.
	(ffecom_lookup_label): Remove obstack use, save appropriate trees.
	(duplicate_decls): Remove obstack use.
	(finish_function): push & pop ggc context around
	rest_of_compilation when building nested function.
	(mark_binding_level): New function.
	(init_decl_processing): Mark all the GC roots.
	(ggc_p): Set to 1.
	(lang_mark_tree): New function.
	(lang_mark_false_label_stack): New trivial function.
	* com.h (ffecom_save_tree_forever): Declare as external.
	* lex.c (ffelex_hash_): Use GC to allocate the filename string
	even when ffelex_kludge_flag_.
	* ste.c (ffeste_io_ialist_): Register a static root.
	(ffeste_io_inlist_): Likewise.
	(ffeste_io_icilist_): Likewise.
	(ffeste_io_cllist_): Likewise.
	(ffeste_io_cilist_): Likewise.
	(ffeste_io_olist_): Likewise.
	* Makefile.in (OBJS): Don't use ggc-callbacks.o.
	(OBJDEPS): Likewise.
	(GGC_H): New variable.
	Update dependencies.
	* where.c (ffewhere_head): New global.
	(mark_ffewhere_head): New marker procedure for ffewhere_head.
	(ffewhere_file_kill): Use GC to do memory management.
	(ffewhere_file_new): Use GC to do memory management.
	* ggc.j: New file.

From-SVN: r31142

gcc/f/ChangeLog

+Thu Dec 30 11:42:05 1999  Geoff Keating  <geoffk@cygnus.com>
+
+	* com.c (ffecom_init_0): Make double_ftype_double,
+	float_ftype_float, ldouble_ftype_ldouble,
+	ffecom_tree_ptr_to_fun_type_void local.
+	(tracker_head): New static variable.
+	(mark_tracker_head): New, marker procedure for tracker_head.
+	(ffecom_save_tree_forever): New procedure.
+	(ffecom_init_zero_): Remove obstack use.
+	(ffecom_make_gfrt_): Remove obstack use.
+	(ffecom_sym_transform_): Remove obstack use, save appropriate trees.
+	(ffecom_transform_common_): Remove obstack use, save appropriate 
+	trees.
+	(ffecom_type_namelist_): Remove obstack use, save appropriate 
+	trees.
+	(ffecom_type_vardesc_): Remove obstack use, save appropriate trees.
+	(ffecom_lookup_label): Remove obstack use, save appropriate trees.
+	(duplicate_decls): Remove obstack use.
+	(finish_function): push & pop ggc context around
+	rest_of_compilation when building nested function.
+	(mark_binding_level): New function.
+	(init_decl_processing): Mark all the GC roots.
+	(ggc_p): Set to 1.
+	(lang_mark_tree): New function.
+	(lang_mark_false_label_stack): New trivial function.
+	* com.h (ffecom_save_tree_forever): Declare as external.
+	* lex.c (ffelex_hash_): Use GC to allocate the filename string
+	even when ffelex_kludge_flag_.
+	* ste.c (ffeste_io_ialist_): Register a static root.
+	(ffeste_io_inlist_): Likewise.
+	(ffeste_io_icilist_): Likewise.
+	(ffeste_io_cllist_): Likewise.
+	(ffeste_io_cilist_): Likewise.
+	(ffeste_io_olist_): Likewise.
+	* Makefile.in (OBJS): Don't use ggc-callbacks.o.
+	(OBJDEPS): Likewise.
+	(GGC_H): New variable.
+	Update dependencies.
+	* where.c (ffewhere_head): New global.
+	(mark_ffewhere_head): New marker procedure for ffewhere_head.
+	(ffewhere_file_kill): Use GC to do memory management.
+	(ffewhere_file_new): Use GC to do memory management.
+	* ggc.j: New file.
+
 Wed Dec 29 19:29:26 1999  Gerald Pfeifer  <pfeifer@dbai.tuwien.ac.at>
 
 	* g77.texi (C Interfacing Tools): Fix an incorrect link.

gcc/f/Make-lang.in

@@ -200,7 +200,7 @@ F77_SRCS = \
  $(srcdir)/f/where.c \
  $(srcdir)/f/where.h
 
-f771$(exeext): $(P) $(F77_SRCS) $(LIBDEPS) ggc-callbacks.o stamp-objlist
+f771$(exeext): $(P) $(F77_SRCS) $(LIBDEPS) stamp-objlist
 	touch lang-f77
 	cd f; $(MAKE) $(FLAGS_TO_PASS) \
 	  HOST_CC="`case '$(HOST_CC)' in stage*) echo '$(HOST_CC)' | sed -e 's|stage|../stage|g';; *) echo '$(HOST_CC)';; esac`" \

gcc/f/Makefile.in

@@ -194,8 +194,8 @@ F77_OBJS = \
  where.o
 
 # Language-independent object files.
-OBJS = `cat ../stamp-objlist` ../ggc-callbacks.o
-OBJDEPS = ../stamp-objlist ../ggc-callbacks.o
+OBJS = `cat ../stamp-objlist`
+OBJDEPS = ../stamp-objlist
 
 compiler: ../f771$(exeext)
 ../f771$(exeext): $(P) $(F77_OBJS) $(OBJDEPS) $(LIBDEPS)
@@ -225,6 +225,7 @@ ASSERT_H = $(srcdir)/assert.j $(srcdir)/../assert.h
 CONFIG_H = $(srcdir)/config.j ../config.h
 CONVERT_H = $(srcdir)/convert.j $(srcdir)/../convert.h
 FLAGS_H = $(srcdir)/flags.j $(srcdir)/../flags.h
+GGC_H = $(srcdir)/ggc.j $(srcdir)/../ggc.h
 GLIMITS_H = $(srcdir)/glimits.j $(srcdir)/../glimits.h
 HCONFIG_H = $(srcdir)/hconfig.j ../hconfig.h
 INPUT_H = $(srcdir)/input.j $(srcdir)/../input.h
@@ -265,7 +266,7 @@ com.o: com.c proj.h $(CONFIG_H) $(SYSTEM_H) $(ASSERT_H) $(FLAGS_H) $(RTL_H) $(TO
  malloc.h info.h info-b.def info-k.def info-w.def target.h bad.h \
  bad.def where.h $(GLIMITS_H) top.h lex.h type.h intrin.h intrin.def \
  lab.h symbol.h symbol.def equiv.h storag.h global.h name.h expr.h \
- implic.h src.h st.h
+ implic.h src.h st.h $(GGC_H)
 data.o: data.c proj.h $(CONFIG_H) $(SYSTEM_H) $(ASSERT_H) data.h bld.h \
  bld-op.def bit.h malloc.h com.h com-rt.def $(TREE_H) info.h info-b.def \
  info-k.def info-w.def target.h bad.h bad.def where.h $(GLIMITS_H) top.h \
@@ -311,7 +312,7 @@ lex.o: lex.c proj.h $(CONFIG_H) $(SYSTEM_H) $(ASSERT_H) top.h malloc.h where.h \
  $(GLIMITS_H) bad.h bad.def com.h com-rt.def $(TREE_H) bld.h bld-op.def \
  bit.h info.h info-b.def info-k.def info-w.def target.h lex.h type.h \
  intrin.h intrin.def lab.h symbol.h symbol.def equiv.h storag.h \
- global.h name.h src.h $(FLAGS_H) $(INPUT_H) $(TOPLEV_H) $(OUTPUT_H)
+ global.h name.h src.h $(FLAGS_H) $(INPUT_H) $(TOPLEV_H) $(OUTPUT_H) $(GGC_H)
 malloc.o: malloc.c proj.h $(CONFIG_H) $(SYSTEM_H) $(ASSERT_H) malloc.h
 name.o: name.c proj.h $(CONFIG_H) $(SYSTEM_H) $(ASSERT_H) bad.h bad.def where.h \
  $(GLIMITS_H) top.h malloc.h name.h global.h info.h info-b.def info-k.def \
@@ -359,7 +360,7 @@ ste.o: ste.c proj.h $(CONFIG_H) $(SYSTEM_H) $(ASSERT_H) $(RTL_H) $(TOPLEV_H) ste
  info-b.def info-k.def info-w.def target.h bad.h bad.def where.h \
  $(GLIMITS_H) top.h lex.h type.h lab.h storag.h symbol.h symbol.def \
  equiv.h global.h name.h intrin.h intrin.def stp.h stt.h stamp-str sts.h \
- stv.h stw.h expr.h sta.h
+ stv.h stw.h expr.h sta.h $(GGC_H)
 storag.o: storag.c proj.h $(CONFIG_H) $(SYSTEM_H) $(ASSERT_H) storag.h bld.h \
  bld-op.def bit.h malloc.h com.h com-rt.def $(TREE_H) info.h info-b.def \
  info-k.def info-w.def target.h bad.h bad.def where.h $(GLIMITS_H) top.h \
@@ -413,7 +414,7 @@ top.o: top.c proj.h $(CONFIG_H) $(SYSTEM_H) $(ASSERT_H) top.h malloc.h where.h \
 type.o: type.c proj.h $(CONFIG_H) $(SYSTEM_H) $(ASSERT_H) type.h malloc.h
 version.o: version.c
 where.o: where.c proj.h $(CONFIG_H) $(SYSTEM_H) $(ASSERT_H) where.h $(GLIMITS_H) \
- top.h malloc.h lex.h
+ top.h malloc.h lex.h $(GGC_H)
 
 # The rest of this list (Fortran 77 language-specific files) is hand-generated.
 

gcc/f/com.c

@@ -93,6 +93,7 @@ the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
 #include "tree.j"
 #include "output.j"  /* Must follow tree.j so TREE_CODE is defined! */
 #include "convert.j"
+#include "ggc.j"
 #endif	/* FFECOM_targetCURRENT == FFECOM_targetGCC */
 
 #define FFECOM_GCC_INCLUDE 1	/* Enable -I. */
@@ -238,17 +239,12 @@ FILE *finput;
 
 tree string_type_node;
 
-static tree double_ftype_double;
-static tree float_ftype_float;
-static tree ldouble_ftype_ldouble;
-
 /* The rest of these are inventions for g77, though there might be
    similar things in the C front end.  As they are found, these
    inventions should be renamed to be canonical.  Note that only
    the ones currently required to be global are so.  */
 
 static tree ffecom_tree_fun_type_void;
-static tree ffecom_tree_ptr_to_fun_type_void;
 
 tree ffecom_integer_type_node;	/* Abbrev for _tree_type[blah][blah]. */
 tree ffecom_integer_zero_node;	/* Like *_*_* with g77's integer type. */
@@ -6433,6 +6429,56 @@ ffecom_gfrt_tree_ (ffecomGfrt ix)
 /* Return initialize-to-zero expression for this VAR_DECL.  */
 
 #if FFECOM_targetCURRENT == FFECOM_targetGCC
+/* A somewhat evil way to prevent the garbage collector
+   from collecting 'tree' structures.  */
+#define NUM_TRACKED_CHUNK 63
+static struct tree_ggc_tracker 
+{
+  struct tree_ggc_tracker *next;
+  tree trees[NUM_TRACKED_CHUNK];
+} *tracker_head = NULL;
+
+static void 
+mark_tracker_head (arg)
+     void *arg;
+{
+  struct tree_ggc_tracker *head;
+  int i;
+  
+  for (head = * (struct tree_ggc_tracker **) arg;
+       head != NULL;
+       head = head->next)
+  {
+    ggc_mark (head);
+    for (i = 0; i < NUM_TRACKED_CHUNK; i++)
+      ggc_mark_tree (head->trees[i]);
+  }
+}
+
+void
+ffecom_save_tree_forever (tree t)
+{
+  int i;
+  if (tracker_head != NULL)
+    for (i = 0; i < NUM_TRACKED_CHUNK; i++)
+      if (tracker_head->trees[i] == NULL)
+	{
+	  tracker_head->trees[i] = t;
+	  return;
+	}
+
+  {
+    /* Need to allocate a new block.  */
+    struct tree_ggc_tracker *old_head = tracker_head;
+    
+    tracker_head = ggc_alloc (sizeof (*tracker_head));
+    tracker_head->next = old_head;
+    tracker_head->trees[0] = t;
+    for (i = 1; i < NUM_TRACKED_CHUNK; i++)
+      tracker_head->trees[i] = NULL;
+  }
+}
+
 static tree
 ffecom_init_zero_ (tree decl)
 {
@@ -6442,14 +6488,8 @@ ffecom_init_zero_ (tree decl)
 
   if (incremental)
     {
-      int momentary = suspend_momentary ();
-      push_obstacks_nochange ();
-      if (TREE_PERMANENT (decl))
-	end_temporary_allocation ();
       make_decl_rtl (decl, NULL, TREE_PUBLIC (decl) ? 1 : 0);
       assemble_variable (decl, TREE_PUBLIC (decl) ? 1 : 0, 0, 1);
-      pop_obstacks ();
-      resume_momentary (momentary);
     }
 
   push_momentary ();
@@ -6966,9 +7006,6 @@ ffecom_make_gfrt_ (ffecomGfrt ix)
   tree t;
   tree ttype;
 
-  push_obstacks_nochange ();
-  end_temporary_allocation ();
-
   switch (ffecom_gfrt_type_[ix])
     {
     case FFECOM_rttypeVOID_:
@@ -7049,9 +7086,6 @@ ffecom_make_gfrt_ (ffecomGfrt ix)
 
   finish_decl (t, NULL_TREE, TRUE);
 
-  resume_temporary_allocation ();
-  pop_obstacks ();
-
   ffecom_gfrt_[ix] = t;
 }
 
@@ -7583,9 +7617,6 @@ ffecom_sym_transform_ (ffesymbol s)
 	      break;
 	    }
 
-	  push_obstacks_nochange ();
-	  end_temporary_allocation ();
-
 	  t = build_decl (FUNCTION_DECL,
 			  ffecom_get_external_identifier_ (s),
 			  ffecom_tree_subr_type);	/* Assume subr. */
@@ -7601,8 +7632,7 @@ ffecom_sym_transform_ (ffesymbol s)
 		  || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
 	    ffeglobal_set_hook (g, t);
 
-	  resume_temporary_allocation ();
-	  pop_obstacks ();
+	  ffecom_save_tree_forever (t);
 
 	  break;
 
@@ -8247,9 +8277,6 @@ ffecom_sym_transform_ (ffesymbol s)
 	      break;
 	    }
 
-	  push_obstacks_nochange ();
-	  end_temporary_allocation ();
-
 	  if (ffesymbol_is_f2c (s)
 	      && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
 	    t = ffecom_tree_fun_type[bt][kt];
@@ -8270,8 +8297,7 @@ ffecom_sym_transform_ (ffesymbol s)
 		  || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
 	    ffeglobal_set_hook (g, t);
 
-	  resume_temporary_allocation ();
-	  pop_obstacks ();
+	  ffecom_save_tree_forever (t);
 
 	  break;
 
@@ -8334,9 +8360,6 @@ ffecom_sym_transform_ (ffesymbol s)
 	      break;
 	    }
 
-	  push_obstacks_nochange ();
-	  end_temporary_allocation ();
-
 	  t = build_decl (FUNCTION_DECL,
 			  ffecom_get_external_identifier_ (s),
 			  ffecom_tree_subr_type);
@@ -8351,8 +8374,7 @@ ffecom_sym_transform_ (ffesymbol s)
 		  || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
 	    ffeglobal_set_hook (g, t);
 
-	  resume_temporary_allocation ();
-	  pop_obstacks ();
+	  ffecom_save_tree_forever (t);
 
 	  break;
 
@@ -8421,9 +8443,6 @@ ffecom_sym_transform_ (ffesymbol s)
 	case FFEINFO_whereGLOBAL:
 	  assert (!ffecom_transform_only_dummies_);
 
-	  push_obstacks_nochange ();
-	  end_temporary_allocation ();
-
 	  t = build_decl (FUNCTION_DECL,
 			  ffecom_get_external_identifier_ (s),
 			  ffecom_tree_blockdata_type);
@@ -8433,8 +8452,7 @@ ffecom_sym_transform_ (ffesymbol s)
 	  t = start_decl (t, FALSE);
 	  finish_decl (t, NULL_TREE, FALSE);
 
-	  resume_temporary_allocation ();
-	  pop_obstacks ();
+	  ffecom_save_tree_forever (t);
 
 	  break;
 
@@ -8757,9 +8775,6 @@ ffecom_transform_common_ (ffesymbol s)
   else
     init = NULL_TREE;
 
-  push_obstacks_nochange ();
-  end_temporary_allocation ();
-
   /* cbtype must be permanently allocated!  */
 
   /* Allocate the MAX of the areas so far, seen filewide.  */
@@ -8831,8 +8846,7 @@ ffecom_transform_common_ (ffesymbol s)
 
   ffestorag_set_hook (st, cbt);
 
-  resume_temporary_allocation ();
-  pop_obstacks ();
+  ffecom_save_tree_forever (cbt);
 }
 
 #endif
@@ -9482,9 +9496,6 @@ ffecom_type_namelist_ ()
 
       vardesctype = ffecom_type_vardesc_ ();
 
-      push_obstacks_nochange ();
-      end_temporary_allocation ();
-
       type = make_node (RECORD_TYPE);
 
       vardesctype = build_pointer_type (build_pointer_type (vardesctype));
@@ -9498,8 +9509,7 @@ ffecom_type_namelist_ ()
       TYPE_FIELDS (type) = namefield;
       layout_type (type);
 
-      resume_temporary_allocation ();
-      pop_obstacks ();
+      ggc_add_tree_root (&type, 1);
     }
 
   return type;
@@ -9553,9 +9563,6 @@ ffecom_type_vardesc_ ()
 
   if (type == NULL_TREE)
     {
-      push_obstacks_nochange ();
-      end_temporary_allocation ();
-
       type = make_node (RECORD_TYPE);
 
       namefield = ffecom_decl_field (type, NULL_TREE, "name",
@@ -9570,8 +9577,7 @@ ffecom_type_vardesc_ ()
       TYPE_FIELDS (type) = namefield;
       layout_type (type);
 
-      resume_temporary_allocation ();
-      pop_obstacks ();
+      ggc_add_tree_root (&type, 1);
     }
 
   return type;
@@ -11566,6 +11572,10 @@ ffecom_init_0 ()
   tree field;
   ffetype type;
   ffetype base_type;
+  tree double_ftype_double;
+  tree float_ftype_float;
+  tree ldouble_ftype_ldouble;
+  tree ffecom_tree_ptr_to_fun_type_void;
 
   /* This block of code comes from the now-obsolete cktyps.c.  It checks
      whether the compiler environment is buggy in known ways, some of which
@@ -12392,9 +12402,6 @@ ffecom_lookup_label (ffelab label)
 	  break;
 
 	case FFELAB_typeFORMAT:
-	  push_obstacks_nochange ();
-	  end_temporary_allocation ();
-
 	  glabel = build_decl (VAR_DECL,
 			       ffecom_get_invented_identifier
 			       ("__g77_format_%d", (int) ffelab_value (label)),
@@ -12409,8 +12416,7 @@ ffecom_lookup_label (ffelab label)
 	  make_decl_rtl (glabel, NULL, 0);
 	  expand_decl (glabel);
 
-	  resume_temporary_allocation ();
-	  pop_obstacks ();
+	  ffecom_save_tree_forever (glabel);
 
 	  break;
 
@@ -13777,17 +13783,6 @@ duplicate_decls (tree newdecl, tree olddecl)
 	  tree oldreturntype = TREE_TYPE (TREE_TYPE (olddecl));
 	  tree newreturntype = TREE_TYPE (TREE_TYPE (newdecl));
 
-	  /* Make sure we put the new type in the same obstack as the old ones.
-	     If the old types are not both in the same obstack, use the
-	     permanent one.  */
-	  if (TYPE_OBSTACK (oldtype) == TYPE_OBSTACK (newtype))
-	    push_obstacks (TYPE_OBSTACK (oldtype), TYPE_OBSTACK (oldtype));
-	  else
-	    {
-	      push_obstacks_nochange ();
-	      end_temporary_allocation ();
-	    }
-
 	  if (TYPE_MODE (oldreturntype) == TYPE_MODE (newreturntype))
 	    {
 	      /* Function types may be shared, so we can't just modify
@@ -13800,8 +13795,6 @@ duplicate_decls (tree newdecl, tree olddecl)
 	      if (types_match)
 		TREE_TYPE (olddecl) = newtype;
 	    }
-
-	  pop_obstacks ();
 	}
       if (!types_match)
 	return 0;
@@ -13830,17 +13823,6 @@ duplicate_decls (tree newdecl, tree olddecl)
 
   if (types_match)
     {
-      /* Make sure we put the new type in the same obstack as the old ones.
-	 If the old types are not both in the same obstack, use the permanent
-	 one.  */
-      if (TYPE_OBSTACK (oldtype) == TYPE_OBSTACK (newtype))
-	push_obstacks (TYPE_OBSTACK (oldtype), TYPE_OBSTACK (oldtype));
-      else
-	{
-	  push_obstacks_nochange ();
-	  end_temporary_allocation ();
-	}
-
       /* Merge the data types specified in the two decls.  */
       if (TREE_CODE (newdecl) != FUNCTION_DECL || !DECL_BUILT_IN (olddecl))
 	TREE_TYPE (newdecl)
@@ -13919,8 +13901,6 @@ duplicate_decls (tree newdecl, tree olddecl)
 	  DECL_STATIC_DESTRUCTOR (newdecl) |= DECL_STATIC_DESTRUCTOR (olddecl);
 	}
 #endif
-
-      pop_obstacks ();
     }
   /* If cannot merge, then use the new type and qualifiers,
      and don't preserve the old rtl.  */
@@ -14244,8 +14224,17 @@ finish_function (int nested)
       /* So we can tell if jump_optimize sets it to 1.  */
       can_reach_end = 0;
 
+      /* If this is a nested function, protect the local variables in the stack
+	 above us from being collected while we're compiling this function.  */
+      if (ggc_p && nested)
+	ggc_push_context ();
+
       /* Run the optimizers and output the assembler code for this function.  */
       rest_of_compilation (fndecl);
+
+      /* Undo the GC context switch.  */
+      if (ggc_p && nested)
+	ggc_pop_context ();
     }
 
   /* Free all the tree nodes making up this function.  */
@@ -14784,10 +14773,87 @@ incomplete_type_error (value, type)
   assert ("incomplete type?!?" == NULL);
 }
 
+/* Mark ARG for GC.  */
+static void 
+mark_binding_level (arg)
+     void *arg;
+{
+  struct binding_level *level = *(struct binding_level **) arg;
+
+  while (level)
+    {
+      ggc_mark_tree (level->names);
+      ggc_mark_tree (level->blocks);
+      ggc_mark_tree (level->this_block);
+      level = level->level_chain;
+    }
+}
+
 void
 init_decl_processing ()
 {
+  static tree *const tree_roots[] = {
+    &current_function_decl,
+    &string_type_node,
+    &ffecom_tree_fun_type_void,
+    &ffecom_integer_zero_node,
+    &ffecom_integer_one_node,
+    &ffecom_tree_subr_type,
+    &ffecom_tree_ptr_to_subr_type,
+    &ffecom_tree_blockdata_type,
+    &ffecom_tree_xargc_,
+    &ffecom_f2c_integer_type_node,
+    &ffecom_f2c_ptr_to_integer_type_node,
+    &ffecom_f2c_address_type_node,
+    &ffecom_f2c_real_type_node,
+    &ffecom_f2c_ptr_to_real_type_node,
+    &ffecom_f2c_doublereal_type_node,
+    &ffecom_f2c_complex_type_node,
+    &ffecom_f2c_doublecomplex_type_node,
+    &ffecom_f2c_longint_type_node,
+    &ffecom_f2c_logical_type_node,
+    &ffecom_f2c_flag_type_node,
+    &ffecom_f2c_ftnlen_type_node,
+    &ffecom_f2c_ftnlen_zero_node,
+    &ffecom_f2c_ftnlen_one_node,
+    &ffecom_f2c_ftnlen_two_node,
+    &ffecom_f2c_ptr_to_ftnlen_type_node,
+    &ffecom_f2c_ftnint_type_node,
+    &ffecom_f2c_ptr_to_ftnint_type_node,
+    &ffecom_outer_function_decl_,
+    &ffecom_previous_function_decl_,
+    &ffecom_which_entrypoint_decl_,
+    &ffecom_float_zero_,
+    &ffecom_float_half_,
+    &ffecom_double_zero_,
+    &ffecom_double_half_,
+    &ffecom_func_result_,
+    &ffecom_func_length_,
+    &ffecom_multi_type_node_,
+    &ffecom_multi_retval_,
+    &named_labels,
+    &shadowed_labels
+  };
+  size_t i;
+
   malloc_init ();
+
+  /* Record our roots.  */
+  for (i = 0; i < sizeof(tree_roots)/sizeof(tree_roots[0]); i++)
+    ggc_add_tree_root (tree_roots[i], 1);
+  ggc_add_tree_root (&ffecom_tree_type[0][0], 
+		     FFEINFO_basictype*FFEINFO_kindtype);
+  ggc_add_tree_root (&ffecom_tree_fun_type[0][0], 
+		     FFEINFO_basictype*FFEINFO_kindtype);
+  ggc_add_tree_root (&ffecom_tree_ptr_to_fun_type[0][0], 
+		     FFEINFO_basictype*FFEINFO_kindtype);
+  ggc_add_tree_root (ffecom_gfrt_, FFECOM_gfrt);
+  ggc_add_root (&current_binding_level, 1, sizeof current_binding_level,
+                mark_binding_level);
+  ggc_add_root (&free_binding_level, 1, sizeof current_binding_level,
+                mark_binding_level);
+  ggc_add_root (&tracker_head, 1, sizeof tracker_head, mark_tracker_head);
+
   ffe_init_0 ();
 }
 
@@ -15753,6 +15819,34 @@ unsigned_type (type)
   return type;
 }
 
+/* Callback routines for garbage collection.  */
+
+int ggc_p = 1;
+
+void 
+lang_mark_tree (t)
+     union tree_node *t ATTRIBUTE_UNUSED;
+{
+  if (TREE_CODE (t) == IDENTIFIER_NODE)
+    {
+      struct lang_identifier *i = (struct lang_identifier *) t;
+      ggc_mark_tree (IDENTIFIER_GLOBAL_VALUE (i));
+      ggc_mark_tree (IDENTIFIER_LOCAL_VALUE (i));
+      ggc_mark_tree (IDENTIFIER_LABEL_VALUE (i));
+    }
+  else if (TYPE_P (t) && TYPE_LANG_SPECIFIC (t))
+    ggc_mark (TYPE_LANG_SPECIFIC (t));
+}
+
+void
+lang_mark_false_label_stack (l)
+     struct label_node *l;
+{
+  /* Fortran doesn't use false_label_stack.  It better be NULL.  */
+  if (l != NULL)
+    abort();
+}
+
 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 
 #if FFECOM_GCC_INCLUDE

gcc/f/com.h

@@ -318,6 +318,7 @@ tree ffecom_lookup_label (ffelab label);
 tree ffecom_make_tempvar (const char *commentary, tree type,
 			  ffetargetCharacterSize size, int elements);
 tree ffecom_modify (tree newtype, tree lhs, tree rhs);
+void ffecom_save_tree_forever (tree t);
 #endif	/* FFECOM_targetCURRENT == FFECOM_targetGCC */
 void ffecom_file (const char *name);
 void ffecom_notify_init_storage (ffestorag st);

gcc/f/ggc.j

+/* rtl.j -- Wrapper for GCC's rtl.h
+   Copyright (C) 1995 Free Software Foundation, Inc.
+   Contributed by James Craig Burley.
+
+This file is part of GNU Fortran.
+
+GNU Fortran 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 2, or (at your option)
+any later version.
+
+GNU Fortran 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 Fortran; see the file COPYING.  If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+02111-1307, USA.  */
+
+#ifndef MAKING_DEPENDENCIES
+#ifndef _J_f_ggc
+#define _J_f_ggc
+#include "system.j"
+#include "config.j"
+#include "ggc.h"
+#endif
+#endif

gcc/f/lex.c

@@ -32,6 +32,7 @@ the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
 #include "toplev.j"
 #include "tree.j"
 #include "output.j"  /* Must follow tree.j so TREE_CODE is defined! */
+#include "ggc.j"
 #endif
 
 #ifdef DWARF_DEBUGGING_INFO
@@ -1320,7 +1321,7 @@ ffelex_hash_ (FILE *finput)
       lineno = l;
 
       if (ffelex_kludge_flag_)
-	input_filename = ffelex_token_text (token);
+	input_filename = ggc_alloc_string (ffelex_token_text (token), -1);
       else
 	{
 	  wf = ffewhere_file_new (ffelex_token_text (token),

gcc/f/ste.c

@@ -35,6 +35,7 @@ the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 #include "rtl.j"
 #include "toplev.j"
+#include "ggc.j"
 #endif
 
 #include "ste.h"
@@ -1218,9 +1219,6 @@ ffeste_io_ialist_ (bool have_err,
     {
       tree ref;
 
-      push_obstacks_nochange ();
-      end_temporary_allocation ();
-
       ref = make_node (RECORD_TYPE);
 
       errfield = ffecom_decl_field (ref, NULL_TREE, "err",
@@ -1231,8 +1229,7 @@ ffeste_io_ialist_ (bool have_err,
       TYPE_FIELDS (ref) = errfield;
       layout_type (ref);
 
-      resume_temporary_allocation ();
-      pop_obstacks ();
+      ggc_add_tree_root (&f2c_alist_struct, 1);
 
       f2c_alist_struct = ref;
     }
@@ -1355,9 +1352,6 @@ ffeste_io_cilist_ (bool have_err,
     {
       tree ref;
 
-      push_obstacks_nochange ();
-      end_temporary_allocation ();
-
       ref = make_node (RECORD_TYPE);
 
       errfield = ffecom_decl_field (ref, NULL_TREE, "err",
@@ -1374,8 +1368,7 @@ ffeste_io_cilist_ (bool have_err,
       TYPE_FIELDS (ref) = errfield;
       layout_type (ref);
 
-      resume_temporary_allocation ();
-      pop_obstacks ();
+      ggc_add_tree_root (&f2c_cilist_struct, 1);
 
       f2c_cilist_struct = ref;
     }
@@ -1586,9 +1579,6 @@ ffeste_io_cllist_ (bool have_err,
     {
       tree ref;
 
-      push_obstacks_nochange ();
-      end_temporary_allocation ();
-
       ref = make_node (RECORD_TYPE);
 
       errfield = ffecom_decl_field (ref, NULL_TREE, "err",
@@ -1601,8 +1591,7 @@ ffeste_io_cllist_ (bool have_err,
       TYPE_FIELDS (ref) = errfield;
       layout_type (ref);
 
-      resume_temporary_allocation ();
-      pop_obstacks ();
+      ggc_add_tree_root (&f2c_close_struct, 1);
 
       f2c_close_struct = ref;
     }
@@ -1713,9 +1702,6 @@ ffeste_io_icilist_ (bool have_err,
     {
       tree ref;
 
-      push_obstacks_nochange ();
-      end_temporary_allocation ();
-
       ref = make_node (RECORD_TYPE);
 
       errfield = ffecom_decl_field (ref, NULL_TREE, "err",
@@ -1734,8 +1720,7 @@ ffeste_io_icilist_ (bool have_err,
       TYPE_FIELDS (ref) = errfield;
       layout_type (ref);
 
-      resume_temporary_allocation ();
-      pop_obstacks ();
+      ggc_add_tree_root (&f2c_icilist_struct, 1);
 
       f2c_icilist_struct = ref;
     }
@@ -1976,9 +1961,6 @@ ffeste_io_inlist_ (bool have_err,
     {
       tree ref;
 
-      push_obstacks_nochange ();
-      end_temporary_allocation ();
-
       ref = make_node (RECORD_TYPE);
 
       errfield = ffecom_decl_field (ref, NULL_TREE, "err",
@@ -2041,8 +2023,7 @@ ffeste_io_inlist_ (bool have_err,
       TYPE_FIELDS (ref) = errfield;
       layout_type (ref);
 
-      resume_temporary_allocation ();
-      pop_obstacks ();
+      ggc_add_tree_root (&f2c_inquire_struct, 1);
 
       f2c_inquire_struct = ref;
     }
@@ -2229,9 +2210,6 @@ ffeste_io_olist_ (bool have_err,
     {
       tree ref;
 
-      push_obstacks_nochange ();
-      end_temporary_allocation ();
-
       ref = make_node (RECORD_TYPE);
 
       errfield = ffecom_decl_field (ref, NULL_TREE, "err",
@@ -2256,8 +2234,7 @@ ffeste_io_olist_ (bool have_err,
       TYPE_FIELDS (ref) = errfield;
       layout_type (ref);
 
-      resume_temporary_allocation ();
-      pop_obstacks ();
+      ggc_add_tree_root (&f2c_open_struct, 1);
 
       f2c_open_struct = ref;
     }

gcc/f/where.c

@@ -33,6 +33,7 @@ the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
 #include "where.h"
 #include "lex.h"
 #include "malloc.h"
+#include "ggc.j"
 
 /* Externals defined here. */
 
@@ -108,6 +109,33 @@ ffewhere_ll_lookup_ (ffewhereLineNumber ln)
   return NULL;
 }
 
+/* A somewhat evil way to prevent the garbage collector
+   from collecting 'file' structures.  */
+#define NUM_FFEWHERE_HEAD_FILES 31
+static struct ffewhere_ggc_tracker 
+{
+  struct ffewhere_ggc_tracker *next;
+  ffewhereFile files[NUM_FFEWHERE_HEAD_FILES];
+} *ffewhere_head = NULL;
+
+static void 
+mark_ffewhere_head (arg)
+     void *arg;
+{
+  struct ffewhere_ggc_tracker *head;
+  int i;
+  
+  for (head = * (struct ffewhere_ggc_tracker **) arg;
+       head != NULL;
+       head = head->next)
+  {
+    ggc_mark (head);
+    for (i = 0; i < NUM_FFEWHERE_HEAD_FILES; i++)
+      ggc_mark (head->files[i]);
+  }
+}
+
+
 /* Kill file object.
 
    Note that this object must not have been passed in a call
@@ -117,9 +145,18 @@ ffewhere_ll_lookup_ (ffewhereLineNumber ln)
 void
 ffewhere_file_kill (ffewhereFile wf)
 {
-  malloc_kill_ks (ffe_pool_file (), wf,
-		  offsetof (struct _ffewhere_file_, text)
-		  + wf->length + 1);
+  struct ffewhere_ggc_tracker *head;
+  int i;
+  
+  for (head = ffewhere_head; head != NULL; head = head->next)
+    for (i = 0; i < NUM_FFEWHERE_HEAD_FILES; i++)
+      if (head->files[i] == wf)
+	{
+	  head->files[i] = NULL;
+	  return;
+	}
+  /* Called on a file that has already been deallocated... */
+  abort();
 }
 
 /* Create file object.  */
@@ -128,14 +165,42 @@ ffewhereFile
 ffewhere_file_new (char *name, size_t length)
 {
   ffewhereFile wf;
+  int filepos;
  
-  wf = malloc_new_ks (ffe_pool_file (), "ffewhereFile",
-		      offsetof (struct _ffewhere_file_, text)
+  wf = ggc_alloc (offsetof (struct _ffewhere_file_, text)
 		  + length + 1);
   wf->length = length;
   memcpy (&wf->text[0], name, length);
   wf->text[length] = '\0';
 
+  if (ffewhere_head == NULL)
+    {
+      ggc_add_root (&ffewhere_head, 1, sizeof ffewhere_head,
+		    mark_ffewhere_head);
+      filepos = NUM_FFEWHERE_HEAD_FILES;
+    }
+  else
+    {
+      for (filepos = 0; filepos < NUM_FFEWHERE_HEAD_FILES; filepos++)
+	if (ffewhere_head->files[filepos] == NULL)
+	  {
+	    ffewhere_head->files[filepos] = wf;
+	    break;
+	  }
+    }
+  if (filepos == NUM_FFEWHERE_HEAD_FILES)
+    {
+      /* Need to allocate a new block.  */
+      struct ffewhere_ggc_tracker *old_head = ffewhere_head;
+      int i;
+      
+      ffewhere_head = ggc_alloc (sizeof (*ffewhere_head));
+      ffewhere_head->next = old_head;
+      ffewhere_head->files[0] = wf;
+      for (i = 1; i < NUM_FFEWHERE_HEAD_FILES; i++)
+	ffewhere_head->files[i] = NULL;
+    }
+
   return wf;
 }