Import Debian changes 5d6-3.2debian/5d6-3.2

scm (5d6-3.2) unstable; urgency=low

  * Fix hppa compile.  Closes: #144062

scm (5d6-3.1) unstable; urgency=low

  * NMU with patch from James Troup, to fix FTBFS on sparc. Closes: #191171

scm (5d6-3) unstable; urgency=low

  * Add build depend on xlibs-dev (Closes: #148020)

scm (5d6-2) unstable; urgency=low

  * Remove libregexx-dev from build-depends.
  * Change build to use ./scmlit rather than scmlit (should fix some build
    problems) (looks like alpha is mostly building)
  * New release (Closes: #140175)
  * Built with turtlegraphics last time (Closes: #58515)

scm (5d6-1) unstable; urgency=low

  * New upstream.
  * Add xlib and turtlegr to requested list of features. (closes
    some bug)
  * Make clean actually clean most everything up.
  * Remove hacks renaming build to something else and just set build as a
    .PHONY target in debian/rules.
  * Add the turtlegr code.

scm (5d5-1) unstable; urgency=low

  * New upstream
  * Has fixes for 64 bit archs.  May fix alpha compile problem.  Does fix
    (Closes: #140175)
  * Take out -O2 arg.

scm (5d4-3) unstable; urgency=low

  * Don't link with regexx, but just use libc6's regular expression
    functions.
  * Define (terms) to output /usr/share/common-licenses/GPL (Closes:
    #119321) 

scm (5d4-2) unstable; urgency=low

  * Add texinfo to build depends (Closes: #107011)

scm (5d4-1) unstable; urgency=low

  * New upstream release.
  * Move install-info --remove to prerm.

scm (5d3-5) unstable; urgency=low

  * Move scm info files to section "The Algorithmic Language Scheme" to
    match up with guile.

scm (5d3-4) unstable; urgency=low

  * Fix build depends (Closes: #76691)

scm (5d3-3) unstable; urgency=low

  * Fix path in scm dhelp file.

scm (5d3-2) unstable; urgency=low

  * Actually put the header files in the package.  Oops.

scm (5d3-1) unstable; urgency=low

  * New upstream. (Closes: #74761)
  * Make (terms) use new license location.
  * Make use libregexx rather than librx.
  * Fix build depends for above.
  * Using new regex lib seems to fix crash (Closes: #66787)
  * Consider adding scm-dev package with headers, but instead just add the
    headers to the scm package. (Closes: #70787)
  * Add doc-base support.

1 files changed, 491 insertions, 173 deletions

diff --git a/sys.c b/sys.c
index b63cb5e..3a8906f 100644
--- a/sys.c
+++ b/sys.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997 Free Software Foundation, Inc.
+/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 2002 Free Software Foundation, Inc.
  *
  * This program is free software; you can redistribute it and/or modify
  * it under the terms of the GNU General Public License as published by
@@ -15,26 +15,26 @@
  * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA.
  *
  * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * for additional uses of the text contained in its release of SCM.
  *
- * The exception is that, if you link the GUILE library with other files
+ * The exception is that, if you link the SCM library with other files
  * to produce an executable, this does not by itself cause the
  * resulting executable to be covered by the GNU General Public License.
  * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
+ * linking the SCM library code into it.
  *
  * This exception does not however invalidate any other reasons why
  * the executable file might be covered by the GNU General Public License.
  *
  * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE.  If you copy
+ * Free Software Foundation under the name SCM.  If you copy
  * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
+ * SCM, as the General Public License permits, the exception does
  * not apply to the code that you add in this way.  To avoid misleading
  * anyone as to the status of such modified files, you must delete
  * this exception notice from them.
  *
- * If you write modifications of your own for GUILE, it is your choice
+ * If you write modifications of your own for SCM, it is your choice
  * whether to permit this exception to apply to your modifications.
  * If you do not wish that, delete this exception notice.
  */
@@ -48,6 +48,7 @@
 void	igc P((char *what, STACKITEM *stackbase));
 void	lfflush P((SCM port));		/* internal SCM call */
 SCM	*loc_open_file;		/* for open-file callback */
+SCM	*loc_try_create_file;
 
 /* ttyname() etc. should be defined in <unistd.h>.  But unistd.h is
    missing on many systems. */
@@ -57,7 +58,7 @@ SCM	*loc_open_file;		/* for open-file callback */
 	char *tmpnam P((char *s));
 	sizet fwrite ();
 # ifdef sun
-#  ifndef __svr4__
+#  ifndef __SVR4
         int fputs P((char *s, FILE* stream));
         int fputc P((char c, FILE* stream));
         int fflush P((FILE* stream));
@@ -72,15 +73,20 @@ SCM	*loc_open_file;		/* for open-file callback */
 # ifdef linux
 #  include <unistd.h>
 # endif
+# ifdef __OpenBSD__
+#  include <unistd.h>
+# endif
 #endif
 
 static void gc_sweep P((int contin_bad));
 
 char	s_nogrow[] = "could not grow", s_heap[] = "heap",
-	s_hplims[] = "hplims";
+  s_hplims[] = "hplims", s_try_create_file[] = "try-create-file";
+
 static char s_segs[] = "segments", s_numheaps[] = "number of heaps";
 static char	s_input_portp[] = "input-port?",
 		s_output_portp[] = "output-port?";
+static char	s_port_closedp[] = "port-closed?";
 static char	s_try_open_file[] = "try-open-file";
 #define	s_open_file (&s_try_open_file[4])
 char	s_close_port[] = "close-port";
@@ -102,7 +108,9 @@ char	s_close_port[] = "close-port";
 #     else
 #      ifndef macintosh
 #       ifndef ARM_ULIB
-#        include <sys/ioctl.h>
+#        ifndef PLAN9
+#         include <sys/ioctl.h>
+#        endif
 #       endif
 #      endif
 #     endif
@@ -129,7 +137,10 @@ SCM i_setbuf0(port)		/* should be called with DEFER_INTS active */
 
 /* The CRDY bit is overloaded to indicate that additional processing
    is needed when reading or writing, such as updating line and column
-   numbers. */
+   numbers.  Returns 0 if cmodes is non-null and modes string is not
+   valid. */
+/* If nonnull, the CMODES argument receives a copy of all chars in MODES
+   which are allowed by ANSI C. */
 long mode_bits(modes, cmodes)
      char *modes, *cmodes;
 {
@@ -143,10 +154,15 @@ long mode_bits(modes, cmodes)
     case 'b': bits |= BINARY; goto outc;
     case '0': bits |= BUF0; break;
     case '?': bits |= (TRACKED | CRDY); break;
+    case 'x': bits |= EXCLUSIVE; break;
     outc: if (cmodes && (iout < 3)) cmodes[iout++] = *modes; break;
     }
-  if (cmodes) cmodes[iout] = 0;
-  return bits;
+  if (!cmodes) return bits;
+  cmodes[iout] = 0;
+  switch (cmodes[0]) {
+  default: return 0;
+  case 'r': case 'w': case 'a': return bits;
+  }
 }
 
 SCM try_open_file(filename, modes)
@@ -155,18 +171,22 @@ SCM try_open_file(filename, modes)
   register SCM port;
   FILE *f;
   char cmodes[4];
-  long flags = mode_bits(CHARS(modes), cmodes);
+  long flags;
   ASSERT(NIMP(filename) && STRINGP(filename), filename, ARG1, s_open_file);
-  ASSERT(NIMP(modes) && STRINGP(modes), modes, ARG2, s_open_file);
-  NEWCELL(port);
+  ASSERT(NIMP(modes) && (STRINGP(modes) || SYMBOLP(modes)), modes, ARG2, s_open_file);
+  flags = mode_bits(CHARS(modes), cmodes);
+  ASSERT(flags, modes, ARG2, s_open_file);
+  if ((EXCLUSIVE & flags) && NIMP(*loc_try_create_file)) {
+    port = apply(*loc_try_create_file, filename, cons(modes, listofnull));
+    if (UNSPECIFIED != port) return port;
+  }
   DEFER_INTS;
-  SCM_OPENCALL(f = fopen(CHARS(filename), cmodes));
+  SCM_OPENCALL((f = fopen(CHARS(filename), cmodes)));
   if (!f) {
     ALLOW_INTS;
     return BOOL_F;
   }
-  SETSTREAM(port, f);
-  CAR(port) = scm_port_entry(tc16_fport, flags);
+  port = scm_port_entry(f, tc16_fport, flags);
   if (BUF0 & flags) i_setbuf0(port);
   ALLOW_INTS;
   SCM_PORTDATA(port) = filename;
@@ -182,6 +202,7 @@ SCM open_file(filename, modes)
 	       cons(modes, listofnull));
 }
 
+long tc16_clport;
 SCM close_port(port)
      SCM port;
 {
@@ -194,6 +215,10 @@ SCM close_port(port)
 	  SYSCALL((ptobs[i].fclose)(STREAM(port)););
 	}
 	CAR(port) &= ~OPN;
+	SCM_PORTFLAGS(port) &= ~OPN;
+	/* Bash the old ptobnum with the closed port ptobnum.
+	   This allows catching some errors cheaply. */
+	SCM_SET_PTOBNUM(port, tc16_clport);
 	ALLOW_INTS;
 	return UNSPECIFIED;
 }
@@ -209,6 +234,24 @@ SCM output_portp(x)
 	if IMP(x) return BOOL_F;
 	return OUTPORTP(x) ? BOOL_T : BOOL_F;
 }
+SCM port_closedp(port)
+     SCM port;
+{
+  ASSERT(NIMP(port) && PORTP(port), port, ARG1, s_port_closedp);
+  if CLOSEDP(port) return BOOL_T;
+  return BOOL_F;
+}
+SCM scm_port_type(port)
+     SCM port;
+{
+  int i;
+  if (NIMP(port) && PORTP(port)) {
+    i = PTOBNUM(port);
+    if (ptobs[i].name) return CAR(sysintern(ptobs[i].name, UNDEFINED));
+    return BOOL_T;
+  }
+  return BOOL_F;
+}
 
 #if (__TURBOC__==1)
 # undef L_tmpnam		/* Not supported in TURBOC V1.0 */
@@ -307,16 +350,25 @@ void prinport(exp, port, type)
 #  ifndef _DCC
 #   ifndef AMIGA
 #    ifndef macintosh
+#     ifndef PLAN9
   if (OPENP(exp) && tc16_fport==TYP16(exp) && isatty(fileno(STREAM(exp))))
     lputs(ttyname(fileno(STREAM(exp))), port);
   else
+#     endif
 #    endif
 #   endif
 #  endif
 # endif
 #endif
-    if OPFPORTP(exp) intprint((long)fileno(STREAM(exp)), 10, port);
-    else intprint(CDR(exp), -16, port);
+    {
+      SCM s = PORTP(exp) ? SCM_PORTDATA(exp) : UNDEFINED;
+      if (NIMP(s) && STRINGP(s))
+	iprin1(s, port, 1);
+      else if (OPFPORTP(exp))
+	intprint((long)fileno(STREAM(exp)), 10, port);
+      else
+	intprint(CDR(exp), -16, port);
+    }
   lputc('>', port);
 }
 
@@ -357,6 +409,24 @@ static int stgetc(p)
   CAR(p) = MAKINUM(ind + 1);
   return UCHARS(CDR(p))[ind];
 }
+static int stclose(p)
+     SCM p;
+{
+  SETCDR(p, nullstr);
+  return 0;
+}
+static int stungetc(c, p)
+     int c;
+     SCM p;
+{
+  sizet ind;
+  p = CDR(p);
+  ind = INUM(CAR(p));
+  if (ind == 0) return EOF;
+  CAR(p) = MAKINUM(--ind);
+  ASSERT(UCHARS(CDR(p))[ind] == c, MAKICHR(c), "stungetc", "");
+  return c;
+}
 int noop0(stream)
      FILE *stream;
 {
@@ -375,7 +445,8 @@ SCM mkstrport(pos, str, modes, caller)
   NEWCELL(z);
   DEFER_INTS;
   SETCHARS(z, str);
-  CAR(z) = scm_port_entry(tc16_strport, modes);
+  CAR(z) = (modes | tc16_strport); /* port table entry 0 is scratch. */
+  /*  z = scm_port_entry((FILE *)str, tc16_strport, modes); */
   ALLOW_INTS;
   return z;
 }
@@ -432,7 +503,7 @@ static ptobfuns fptob = {
 ptobfuns pipob = {
   0,
   mark0,
-  0,				/* replaced by pclose in init_ioext() */
+  0,				/* replaced by pclose in init_posix() */
   0,
   0,
   fputc,
@@ -456,8 +527,8 @@ static ptobfuns stptob = {
   stwrite,
   noop0,
   stgetc,
-  0};				/* stungetc */
-
+  stclose,
+  stungetc};
 
 				/* Soft ports */
 
@@ -523,6 +594,7 @@ SCM mksfpt(pv, modes)
      SCM pv, modes;
 {
   SCM z;
+  long flags;
   static long arities[] = {1, 1, 0, 0, 0};
 #ifndef RECKLESS
   int i;
@@ -534,11 +606,11 @@ SCM mksfpt(pv, modes)
 	   badarg);
   }
 #endif
-  ASSERT(NIMP(modes) && STRINGP(modes), modes, ARG2, s_mksfpt);
-  NEWCELL(z);
+  ASSERT(NIMP(modes) && (STRINGP(modes) || SYMBOLP(modes)), modes, ARG2, s_mksfpt);
+  flags = mode_bits(CHARS(modes), (char *)0);
+  ASSERT(flags, modes, ARG2, s_mksfpt);
   DEFER_INTS;
-  CAR(z) = scm_port_entry(tc16_sfport, mode_bits(CHARS(modes), (char *)0));
-  SETSTREAM(z, pv);
+  z = scm_port_entry((FILE *)pv, tc16_sfport, flags);
   ALLOW_INTS;
   return z;
 }
@@ -556,6 +628,42 @@ static ptobfuns sfptob = {
   sfgetc,
   sfclose};
 
+		/* Closed ports, just return an error code and let
+		   the caller complain. */
+static int clputc(c, p)
+     int c; FILE *p;
+{
+  return EOF;
+}
+static sizet clwrite(str, siz, num, p)
+     sizet siz, num;
+     char *str; FILE *p;
+{
+  return 0;
+}
+static int clputs(s, p)
+     char *s; FILE *p;
+{
+  return EOF;
+}
+static int clgetc(p)
+     FILE *p;
+{
+  return EOF;
+}
+static ptobfuns clptob = {
+  s_port_type,
+  mark0,
+  noop0,
+  0,
+  0,
+  clputc,
+  clputs,
+  clwrite,
+  clgetc,
+  clgetc,
+  0};
+
 /* The following ptob is for printing system messages in an interrupt-safe
    way.  Writing to sys_errp while interrupts are disabled will never enable
    interrupts, do any actual i/o, or any allocation.  Messages will be
@@ -583,7 +691,7 @@ static sizet syswrite(str, siz, num, p)
     if NIMP(cur_outp) lflush(cur_outp);
     if (errbuf_end > 0) {
       if (errbuf_end > SYS_ERRP_SIZE) {
-	scm_warn("output buffer", " overflowed");
+	scm_warn("output buffer", " overflowed", UNDEFINED);
 	intprint((long)errbuf_end, 10, cur_errp);
 	lputs(" chars needed\n", cur_errp);
 	errbuf_end = errbuf_end % SYS_ERRP_SIZE;
@@ -644,16 +752,12 @@ SCM mksafeport(maxlen, port)
 {
   SCM z;
   if UNBNDP(port) port = cur_errp;
-  else {
-    ASSERT(NIMP(port) && OPPORTP(port), port, ARG2, s_msp);
-  }
-  DEFER_INTS;
+  ASSERT(NIMP(port) && OPPORTP(port), port, ARG2, s_msp);
   z = must_malloc_cell(sizeof(safeport)+0L,
 		       tc16_safeport | OPN | WRTNG,
 		       s_msp);
   ((safeport *)STREAM(z))->ccnt = maxlen;
   ((safeport *)STREAM(z))->port = port;
-  ALLOW_INTS;
   return z;
 }
 int reset_safeport(sfp, maxlen, port)
@@ -685,7 +789,7 @@ static sizet safewrite(str, siz, num, p)
     lputs(" ...", p->port);
     longjmp(p->jmpbuf, !0);	/* The usual C longjmp, not SCM's longjump */
   }
-  return siz;
+  return num;
 }
 static int safeputs(s, p)
      char *s; safeport *p;
@@ -787,33 +891,35 @@ extern sizet num_protects;	/* sys_protects now in scl.c */
 void init_types()
 {
   sizet j = num_protects;
-  /* Because not all protects may get initialized */
-  while(j) sys_protects[--j] = BOOL_F;
+  while(j) sys_protects[--j] = UNDEFINED;
 
   /* We need to set up tmp_errp before any errors may be
-     thrown, the port_table index will be zero, usable
+     thrown, the port_table index will be zero, usable by
      all ports that don't care about their table entries. */
   tmp_errp = PTR2SCM(CELL_UP(&tmp_errpbuf[0]));
-  CAR(tmp_errp) = scm_port_entry(tc16_fport, OPN|WRTNG);
+  CAR(tmp_errp) = tc16_fport | OPN | WRTNG;
+  /*  CAR(tmp_errp) = scm_port_entry(tc16_fport, OPN|WRTNG); */
   SETSTREAM(tmp_errp, stderr);
   cur_errp = def_errp = sys_safep = tmp_errp;
 
-  scm_init_gra(&subr_table_gra, sizeof(subr_info), 200, 0, "subr table");
-  scm_init_gra(&ptobs_gra, sizeof(ptobfuns), 4, 255, "ptobs");
+  /* subrs_gra is trimmed to actual used by scm_init_extensions() */
+  scm_init_gra(&subrs_gra, sizeof(subr_info), 420 , 0, "subrs");
+  scm_init_gra(&ptobs_gra, sizeof(ptobfuns), 8, 255, "ptobs");
   /* These newptob calls must be done in this order */
   /* tc16_fport = */ newptob(&fptob);
   /* tc16_pipe = */ newptob(&pipob);
   /* tc16_strport = */ newptob(&stptob);
   /* tc16_sfport = */ newptob(&sfptob);
+  tc16_clport = newptob(&clptob);
   tc16_sysport = newptob(&sysptob);
   tc16_safeport = newptob(&safeptob);
-  scm_init_gra(&smobs_gra, sizeof(smobfuns), 7, 255, "smobs");
+  scm_init_gra(&smobs_gra, sizeof(smobfuns), 16, 255, "smobs");
   /* These newsmob calls must be done in this order */
   newsmob(&freecell);
   newsmob(&flob);
   newsmob(&bigob);
   newsmob(&bigob);
-  scm_init_gra(&finals_gra, sizeof(void (*)()), 2, 0, s_final);
+  scm_init_gra(&finals_gra, sizeof(void (*)()), 4, 0, s_final);
 }
 
 #ifdef TEST_FINAL
@@ -828,6 +934,24 @@ void add_final(final)
   scm_grow_gra(&finals_gra, (char *)&final);
 }
 
+static SCM gc_finalizers = EOL, gc_finalizers_pending = EOL;
+static char s_add_finalizer[] = "add-finalizer";
+SCM scm_add_finalizer(value, finalizer)
+     SCM value, finalizer;
+{
+  SCM z;
+  ASSERT(NIMP(value), value, ARG1, s_add_finalizer);
+#ifndef RECKLESS
+  scm_arity_check(finalizer, 0L, s_add_finalizer);
+#endif
+  z = acons(value, finalizer, EOL);
+  DEFER_INTS;
+  CDR(z) = gc_finalizers;
+  gc_finalizers = z;
+  ALLOW_INTS;
+  return UNSPECIFIED;
+}
+
 static char s_estk[] = "environment stack";
 static cell ecache_v[ECACHE_SIZE];
 SCM scm_egc_roots[ECACHE_SIZE/20];
@@ -877,7 +1001,7 @@ void scm_estk_reset(size)
   if (!size) size = SCM_ESTK_BASE + 20*SCM_ESTK_FRLEN + 1;
   scm_estk = make_stk_seg(size, UNDEFINED);
   scm_estk_ptr = &(VELTS(scm_estk)[SCM_ESTK_BASE]);
-  scm_estk_size = size;
+  scm_estk_size = size + 0L;
 }
 void scm_estk_grow()
 {
@@ -891,7 +1015,7 @@ void scm_estk_grow()
   sizet i, j;
   newv = VELTS(estk);
   oldv = VELTS(scm_estk);
-  j = scm_estk_ptr - VELTS(scm_estk) + SCM_ESTK_FRLEN - overlap;
+  j = scm_estk_ptr - oldv + SCM_ESTK_FRLEN - overlap;
   SCM_ESTK_PARENT(estk) = scm_estk;
   SCM_ESTK_PARENT_WRITABLEP(estk) = BOOL_T;
   SCM_ESTK_PARENT_INDEX(estk) = MAKINUM(j - SCM_ESTK_FRLEN);
@@ -901,19 +1025,18 @@ void scm_estk_grow()
   }
   scm_estk = estk;
   scm_estk_ptr = &(newv[SCM_ESTK_BASE + overlap]);
-  scm_estk_size += size;
+  scm_estk_size += size + 0L;
   /*  growth_mon(s_estk, scm_estk_size, "locations", !0); */
 }
 void scm_estk_shrink()
 {
-  SCM parent, *v;
+  SCM parent;
   sizet i;
   parent = SCM_ESTK_PARENT(scm_estk);
   i = INUM(SCM_ESTK_PARENT_INDEX(scm_estk));
-  v = VELTS(scm_estk);
   if IMP(parent) wta(UNDEFINED, "underflow", s_estk);
   if (BOOL_F==SCM_ESTK_PARENT_WRITABLEP(scm_estk))
-    parent = make_stk_seg(LENGTH(parent), parent);
+    parent = make_stk_seg((sizet)LENGTH(parent), parent);
   SCM_ESTK_PARENT(scm_estk) = estk_pool;
   estk_pool = scm_estk;
   scm_estk_size -= LENGTH(scm_estk);
@@ -961,27 +1084,32 @@ void scm_env_cons2(w, x, y)
    scm_ecache_index = i;
 }
 
-/* scm_env_tmp = cons(x, scm_env_tmp) */
-void scm_env_cons_tmp(x)
-     SCM x;
+void scm_env_cons3(v, w, x, y)
+     SCM v, w, x, y;
 {
-   register SCM z;
+   SCM z1, z2;
    register int i;
    DEFER_INTS_EGC;
    i = scm_ecache_index;
-   if (1>i) {
+   if (3>i) {
      scm_egc();
      i = scm_ecache_index;
    }
-   z = PTR2SCM(&(scm_ecache[--i]));
-   CAR(z) = x;
-   CDR(z) = scm_env_tmp;
-   scm_env_tmp = z;
+   z1 = PTR2SCM(&(scm_ecache[--i]));
+   CAR(z1) = x;
+   CDR(z1) = y;
+   z2 = PTR2SCM(&(scm_ecache[--i]));
+   CAR(z2) = w;
+   CDR(z2) = z1;
+   z1 = PTR2SCM(&(scm_ecache[--i]));
+   CAR(z1) = v;
+   CDR(z1) = z2;
+   scm_env_tmp = z1;
    scm_ecache_index = i;
 }
 
 void scm_env_v2lst(argc, argv)
-     int argc;
+     long argc;
      SCM *argv;
 {
    SCM z1, z2;
@@ -1004,7 +1132,23 @@ void scm_env_v2lst(argc, argv)
 }
 
 /* scm_env = acons(names, scm_env_tmp, scm_env) */
-void scm_extend_env(names)
+void scm_extend_env()
+{
+   SCM z;
+   register int i;
+   DEFER_INTS_EGC;
+   i = scm_ecache_index;
+   if (1>i) {
+     scm_egc();
+     i = scm_ecache_index;
+   }
+   z = PTR2SCM(&(scm_ecache[--i]));
+   CAR(z) = scm_env_tmp;
+   CDR(z) = scm_env;
+   scm_env = z;
+   scm_ecache_index = i;
+}
+void old_scm_extend_env(names)
      SCM names;
 {
    SCM z1, z2;
@@ -1028,15 +1172,17 @@ char s_obunhash[] = "object-unhash", s_cache_gc[] = "cache_gc";
 char s_recursive[] = "recursive";
 #define s_gc (s_cache_gc+6)
 static iproc subr0s[] = {
-  /*	{s_gc, gc}, */
 	{"tmpnam", ltmpnam},
+	{"open-ports", scm_open_ports},
 	{0, 0}};
 
 static iproc subr1s[] = {
 	{s_input_portp, input_portp},
 	{s_output_portp, output_portp},
+	{s_port_closedp, port_closedp},
 	{s_close_port, close_port},
 	{"eof-object?", eof_objectp},
+	{"port-type", scm_port_type},
 	{s_cwos, cwos},
 	{"object-hash", obhash},
 	{s_obunhash, obunhash},
@@ -1047,6 +1193,7 @@ static iproc subr2s[] = {
 	{s_try_open_file, try_open_file},
 	{s_cwis, cwis},
 	{s_mksfpt, mksfpt},
+	{s_add_finalizer, scm_add_finalizer},
 	{0, 0}};
 
 SCM dynwind P((SCM thunk1, SCM thunk2, SCM thunk3));
@@ -1060,6 +1207,7 @@ void init_io()
   loc_open_file =
     &CDR(sysintern(s_open_file,
 		   CDR(sysintern(s_try_open_file, UNDEFINED))));
+  loc_try_create_file = &CDR(sysintern(s_try_create_file, UNDEFINED));
 #ifndef CHEAP_CONTINUATIONS
   add_feature("full-continuation");
 #endif
@@ -1079,6 +1227,7 @@ long heap_cells = 0;
 CELLPTR *hplims, heap_org;
 VOLATILE SCM freelist = EOL;
 long mltrigger, mtrigger = INIT_MALLOC_LIMIT;
+int gc_hook_pending = 0, gc_hook_active = 0;
 
 /* Ints should be deferred when calling igc_for_alloc. */
 static char *igc_for_alloc(where, olen, size, what)
@@ -1090,17 +1239,16 @@ static char *igc_for_alloc(where, olen, size, what)
   char *ptr;
   long nm;
 			/* Check to see that heap is initialized */
-  ASSERT(heap_cells>0, MAKINUM(size), NALLOC, what);
+  ASSERT(heap_cells > 0, MAKINUM(size), NALLOC, what);
+/* printf("igc_for_alloc(%lx, %lu, %u, %s)\n", where, olen, size, what); fflush(stdout); */
   igc(what, CONT(rootcont)->stkbse);
   nm = mallocated + size - olen;
   if (nm > mltrigger) {
     if (nm > mtrigger) grew_lim(nm + nm/2);
     else grew_lim(mtrigger + mtrigger/2);
   }
-  if (where)
-    SYSCALL(ptr = (char *)realloc(where, size););
-  else
-    SYSCALL(ptr = (char *)malloc(size););
+  if (where) SYSCALL(ptr = (char *)realloc(where, size););
+  else SYSCALL(ptr = (char *)malloc(size););
   ASSERT(ptr, MAKINUM(size), NALLOC, what);
   if (nm > mltrigger) {
     if (nm > mtrigger) mtrigger = nm + nm/2;
@@ -1121,14 +1269,11 @@ char *must_malloc(len, what)
 #ifdef SHORT_SIZET
   ASSERT(len==size, MAKINUM(len), NALLOC, what);
 #endif
-  if (nm <= mtrigger)
-    SYSCALL(ptr = (char *)malloc(size););
-  else
-    ptr = 0;
-  if (!ptr)
-    ptr = igc_for_alloc(0L, 0L, size, what);
-  else
-    mallocated = nm;
+  if (nm <= mtrigger) SYSCALL(ptr = (char *)malloc(size););
+  else ptr = 0;
+  if (!ptr) ptr = igc_for_alloc(0L, 0L, size, what);
+  else mallocated = nm;
+/* printf("must_malloc(%lu, %s) => %lx\n", len, what, ptr); fflush(stdout); */
   return ptr;
 }
 SCM must_malloc_cell(len, c, what)
@@ -1145,14 +1290,11 @@ SCM must_malloc_cell(len, c, what)
   ASSERT(len==size, MAKINUM(len), NALLOC, what);
 #endif
   NEWCELL(z);
-  if (nm <= mtrigger)
-    SYSCALL(ptr = (char *)malloc(size););
-  else
-    ptr = 0;
-  if (!ptr)
-    ptr = igc_for_alloc(0L, 0L, size, what);
-  else
-    mallocated = nm;
+  if (nm <= mtrigger) SYSCALL(ptr = (char *)malloc(size););
+  else ptr = 0;
+  if (!ptr) ptr = igc_for_alloc(0L, 0L, size, what);
+  else mallocated = nm;
+/* printf("must_malloc_cell(%lu, %lx, %s) => %lx\n", len, c, what, ptr); fflush(stdout); */
   SETCHARS(z, ptr);
   CAR(z) = c;
   return z;
@@ -1169,14 +1311,13 @@ char *must_realloc(where, olen, len, what)
 #ifdef SHORT_SIZET
   ASSERT(len==size, MAKINUM(len), NALLOC, what);
 #endif
-  if (nm <= mtrigger)
-    SYSCALL(ptr = (char *)realloc(where, size););
-  else
-    ptr = 0;
-  if (!ptr)
-    ptr = igc_for_alloc(where, olen, size, what);
-  else
-    mallocated = nm;
+  ASSERT(!errjmp_bad, MAKINUM(len), NALLOC, what);
+/* printf("must_realloc(%lx, %lu, %lu, %s)\n", where, olen, len, what); fflush(stdout);
+   printf("nm = %ld <= mtrigger = %ld: %d; size = %u\n", nm, mtrigger, (nm <= mtrigger), size); fflush(stdout); */
+  if (nm <= mtrigger) SYSCALL(ptr = (char *)realloc(where, size););
+  else ptr = 0;
+  if (!ptr) ptr = igc_for_alloc(where, olen, size, what);
+  else mallocated = nm;
   return ptr;
 }
 void must_realloc_cell(z, olen, len, what)
@@ -1191,14 +1332,12 @@ void must_realloc_cell(z, olen, len, what)
 #ifdef SHORT_SIZET
   ASSERT(len==size, MAKINUM(len), NALLOC, what);
 #endif
-  if (nm <= mtrigger)
-    SYSCALL(ptr = (char *)realloc(where, size););
-  else
-    ptr = 0;
-  if (!ptr)
-    ptr = igc_for_alloc(where, olen, size, what);
-  else
-    mallocated = nm;
+  ASSERT(!errjmp_bad, MAKINUM(len), NALLOC, what);
+/* printf("must_realloc_cell(%lx, %lu, %lu, %s)\n", z, olen, len, what); fflush(stdout); */
+  if (nm <= mtrigger) SYSCALL(ptr = (char *)realloc(where, size););
+  else ptr = 0;
+  if (!ptr) ptr = igc_for_alloc(where, olen, size, what);
+  else mallocated = nm;
   SETCHARS(z, ptr);
 }
 void must_free(obj, len)
@@ -1209,6 +1348,7 @@ void must_free(obj, len)
 #ifdef CAREFUL_INTS
     while (len--) obj[len] = '#';
 #endif
+/* printf("free(%lx)\n", obj); fflush(stdout); */
     free(obj);
     mallocated = mallocated - len;
   }
@@ -1243,7 +1383,7 @@ SCM intern(name, len)
   register sizet i = len;
   register unsigned char *tmp = (unsigned char *)name;
   sizet hash = strhash(tmp, i, (unsigned long)symhash_dim);
-  /* printf("intern %s len=%d\n",name,len);fflush(stdout); */
+  /* printf("intern %s len=%d\n",name,len); fflush(stdout); */
   DEFER_INTS;
   for(lsym = VELTS(symhash)[hash];NIMP(lsym);lsym = CDR(lsym)) {
     z = CAR(lsym);
@@ -1256,8 +1396,7 @@ SCM intern(name, len)
   trynext: ;
   }
   /*  lsym = makfromstr(name, len); */
-  lsym = must_malloc_cell(len+1L,
-			  MAKE_LENGTH((long)len, tc7_msymbol), s_string);
+  lsym = must_malloc_cell(len+1L, MAKE_LENGTH(len, tc7_msymbol), s_string);
   i = len;
   CHARS(lsym)[len] = 0;
   while (i--) CHARS(lsym)[i] = name[i];
@@ -1284,16 +1423,15 @@ SCM sysintern(name, val)
     if (LENGTH(z) != len) goto trynext;
     for(i = len;i--;) if (((unsigned char *)name)[i] != tmp[i]) goto trynext;
     lsym = CAR(lsym);
-    if (!UNBNDP(val))
-      CDR(lsym) = val;
+    if (!UNBNDP(val)) CDR(lsym) = val;
+    else if (UNBNDP(CDR(lsym)) && tc7_msymbol==TYP7(CAR(lsym)))
+      scm_gc_protect(lsym);
     return lsym;
   trynext: ;
   }
   NEWCELL(lsym);
-  DEFER_INTS;
-  SETLENGTH(lsym, (long)len, tc7_ssymbol);
+  SETLENGTH(lsym, len, tc7_ssymbol);
   SETCHARS(lsym, name);
-  ALLOW_INTS;
   lsym = cons(lsym, val);
   z = cons(lsym, UNDEFINED);
   CDR(z) = VELTS(symhash)[hash];
@@ -1350,7 +1488,7 @@ SCM makstr(len)
 	return s;
 }
 
-scm_gra subr_table_gra;
+scm_gra subrs_gra;
 SCM scm_maksubr(name, type, fcn)
      const char *name;
      int type;
@@ -1360,7 +1498,7 @@ SCM scm_maksubr(name, type, fcn)
 	int isubr;
 	register SCM z;
 	info.name = name;
-	isubr = scm_grow_gra(&subr_table_gra, (char *)&info);
+	isubr = scm_grow_gra(&subrs_gra, (char *)&info);
 	NEWCELL(z);
 	if (!fcn && tc7_cxr==type) {
 	  const char *p = name;
@@ -1484,7 +1622,7 @@ SCM scm_make_cont()
 #else
   from[1] = BOOL_F;		/* Can't write to parent stack */
   estk = must_malloc_cell((long)n*sizeof(SCM),
-			  MAKE_LENGTH((long)n, tc7_vector), s_cont);
+			  MAKE_LENGTH(n, tc7_vector), s_cont);
   {
     SCM *to = VELTS(estk);
     while(n--) to[n] = from[n];
@@ -1500,6 +1638,10 @@ SCM scm_make_cont()
   ncont->other.stkframe[1] = scm_env_tmp;
   ncont->other.estk = estk;
   ncont->other.estk_ptr = scm_estk_ptr;
+#ifndef RECKLESS
+  ncont->other.stkframe[2] = scm_trace_env;
+  ncont->other.stkframe[3] = scm_trace;
+#endif
   return cont;
 }
 static char s_sstale[] = "strangely stale";
@@ -1521,14 +1663,17 @@ void scm_dynthrow(tocont, val)
       SCM *from =  VELTS(cont->other.estk);
       SCM *to = VELTS(scm_estk);
       sizet n = LENGTH(cont->other.estk);
-      if (LENGTH(scm_estk) < n)
-	scm_estk_reset((sizet)LENGTH(scm_estk));
+      if (LENGTH(scm_estk) < n) scm_estk_reset((sizet)LENGTH(scm_estk));
       scm_estk_ptr = &(to[n]) - SCM_ESTK_FRLEN;
       while(n--) to[n] = from[n];
     }
 #endif
     scm_env = cont->other.stkframe[0];
     scm_env_tmp = cont->other.stkframe[1];
+#ifndef RECKLESS
+    scm_trace_env = cont->other.stkframe[2];
+    scm_trace = cont->other.stkframe[3];
+#endif
     ALLOW_INTS;
   }
   throw_to_continuation(cont, val, CONT(rootcont));
@@ -1621,6 +1766,24 @@ static void fixconfig(s1, s2, s)
   quit(MAKINUM(1L));
 }
 
+void heap_report()
+{
+  sizet i = 0;
+  if (hplim_ind) lputs("; heap segments:", sys_errp);
+  while(i < hplim_ind) {
+    {
+      long seg_cells = CELL_DN(hplims[i+1]) - CELL_UP(hplims[i]);
+      lputs("\n; 0x", sys_errp);
+      intprint((long)hplims[i++], -16, sys_errp);
+      lputs(" - 0x", sys_errp);
+      intprint((long)hplims[i++], -16, sys_errp);
+      lputs("; ", sys_errp);
+      intprint(seg_cells, 10, sys_errp);
+      lputs(" cells; ", sys_errp);
+      intprint(seg_cells / (1024 / sizeof(CELLPTR)), 10, sys_errp);
+      lputs(".kiB", sys_errp);
+    }}
+}
 sizet init_heap_seg(seg_org, size)
      CELLPTR seg_org;
      sizet size;
@@ -1641,6 +1804,8 @@ sizet init_heap_seg(seg_org, size)
   hplims[ni++] = seg_end;
   ptr = CELL_UP(ptr);
   ni = seg_end - ptr;
+/* printf("ni = %u; hplim_ind = %u\n", ni, hplim_ind); */
+/* printf("ptr = %lx\n", ptr); */
   for (i = ni;i--;ptr++) {
 #ifdef POINTERS_MUNGED
     scmptr = PTR2SCM(ptr);
@@ -1696,12 +1861,12 @@ void scm_init_gra(gra, eltsize, len, maxlen, what)
      char *what;
 {
   char *nelts;
-  DEFER_INTS;
+  /* DEFER_INTS; */
   /* Can't call must_malloc, because heap may not be initialized yet. */
   /*  SYSCALL(nelts = malloc(len*eltsize););
       if (!nelts) wta(MAKINUM(len*eltsize), (char *)NALLOC, what);
       mallocated += len*eltsize;
- */
+  */
   nelts = must_malloc((long)len*eltsize, what);
   gra->eltsize = eltsize;
   gra->len = 0;
@@ -1709,7 +1874,7 @@ void scm_init_gra(gra, eltsize, len, maxlen, what)
   gra->alloclen = len;
   gra->maxlen = maxlen;
   gra->what = what;
-  ALLOW_INTS;
+  /* ALLOW_INTS; */
 }
 /* Returns the index into the elt array */
 int scm_grow_gra(gra, elt)
@@ -1718,12 +1883,11 @@ int scm_grow_gra(gra, elt)
 {
   int i;
   char *tmp;
-  DEFER_INTS;
   if (gra->alloclen <= gra->len) {
     sizet inc = gra->len / 5 + 1;
     sizet nlen = gra->len + inc;
     if (gra->maxlen && nlen > gra->maxlen)
-      growerr: wta(MAKINUM(nlen), (char *)NALLOC, gra->what);
+      /* growerr: */ wta(MAKINUM(nlen), (char *)NALLOC, gra->what);
     /*
       SYSCALL(tmp = realloc(gra->elts, nlen*gra->eltsize););
       if (!tmp) goto growerr;
@@ -1738,9 +1902,22 @@ int scm_grow_gra(gra, elt)
   gra->len += 1;
   for (i = 0; i < gra->eltsize; i++)
     tmp[i] = elt[i];
-  ALLOW_INTS;
   return gra->len - 1;
 }
+void scm_trim_gra(gra)
+     scm_gra *gra;
+{
+  char *tmp;
+  long curlen = gra->len;
+  if (0L==curlen) curlen = 1L;
+  if (curlen==(long)gra->alloclen) return;
+  tmp = must_realloc(gra->elts,
+		     (long)gra->alloclen * gra->eltsize,
+		     curlen * gra->eltsize,
+		     gra->what);
+  gra->elts = tmp;
+  gra->alloclen = curlen;
+}
 void scm_free_gra(gra)
      scm_gra *gra;
 {
@@ -1748,6 +1925,26 @@ void scm_free_gra(gra)
   gra->elts = 0;
   mallocated -= gra->maxlen*gra->eltsize;
 }
+void gra_report1(gra)
+     scm_gra *gra;
+{
+  intprint((long)gra->len, -10, cur_errp);
+  lputs(" (of ", cur_errp);
+  intprint((long)gra->alloclen, -10, cur_errp);
+  lputs(") ", cur_errp);
+  lputs(gra->what, cur_errp);
+  lputs("; ", cur_errp);
+}
+void gra_report()
+{
+  lputs(";; gra: ", cur_errp);
+  gra_report1(&ptobs_gra);
+  gra_report1(&smobs_gra);
+  gra_report1(&finals_gra);
+  gra_report1(&subrs_gra);
+  lputs("\n", cur_errp);
+}
+
 scm_gra smobs_gra;
 long newsmob(smob)
      smobfuns *smob;
@@ -1760,38 +1957,35 @@ long newptob(ptob)
 {
   return tc7_port + 256*scm_grow_gra(&ptobs_gra, (char *)ptob);
 }
-#define PORT_TABLE_MAXLEN (1 + ((int)((unsigned long)~0L>>20)))
 port_info *scm_port_table = 0;
-static int scm_port_table_len = 0;
+static sizet scm_port_table_len = 0;
 static char s_port_table[] = "port table";
-SCM scm_port_entry(ptype, flags)
+SCM scm_port_entry(stream, ptype, flags)
+     FILE *stream;
      long ptype, flags;
 {
-  int nlen;
+  SCM z;
+  sizet nlen;
   int i, j;
   VERIFY_INTS("scm_port_entry", 0L);
   flags = flags | (ptype & ~0xffffL);
   ASSERT(flags, INUM0, ARG1, "scm_port_entry");
-  for (i = 0; i < scm_port_table_len; i++)
+  for (i = 1; i < scm_port_table_len; i++)
     if (0L==scm_port_table[i].flags) goto ret;
-  if (0==scm_port_table_len) {	/* Initialize */
-    scm_port_table_len = 16;
-    scm_port_table = (port_info *)
-      must_malloc((long)scm_port_table_len*sizeof(port_info), s_port_table);
-  }
-  else if (scm_port_table_len < PORT_TABLE_MAXLEN) {
+  if (scm_port_table_len <= SCM_PORTNUM_MAX) {
     nlen = scm_port_table_len + (scm_port_table_len / 2);
-    if (nlen > PORT_TABLE_MAXLEN) nlen = PORT_TABLE_MAXLEN;
+    if (nlen >= SCM_PORTNUM_MAX) nlen = (sizet)SCM_PORTNUM_MAX + 1;
     scm_port_table = (port_info *)
       must_realloc((char *)scm_port_table,
-		   (long)scm_port_table_len*sizeof(port_info),
-		   nlen*sizeof(port_info)+0L,
+		   (long)scm_port_table_len * sizeof(port_info),
+		   (long)nlen * sizeof(port_info),
 		   s_port_table);
     scm_port_table_len = nlen;
-    growth_mon(s_port_table, nlen+0L, "entries", !0);
+    growth_mon(s_port_table, nlen + 0L, "entries", !0);
     for (j = i; j < scm_port_table_len; j++) {
       scm_port_table[j].flags = 0L;
-      scm_port_table[j].data = EOL;
+      scm_port_table[j].data = UNDEFINED;
+      scm_port_table[j].port = UNDEFINED;
     }
   }
   else {
@@ -1801,12 +1995,27 @@ SCM scm_port_entry(ptype, flags)
     wta(UNDEFINED, s_nogrow, s_port_table);
   }
  ret:
+  NEWCELL(z);
+  SETSTREAM(z, stream);
+  CAR(z) = (((long)i)<<20) | (flags & 0x0f0000) | ptype;
   scm_port_table[i].unread = EOF;
   scm_port_table[i].flags = flags;
   scm_port_table[i].line = 1L;	/* should both be one-based? */
   scm_port_table[i].col = 1;
   scm_port_table[i].data = UNSPECIFIED;
-  return (((long)i)<<20) | (flags & 0x0f0000) | ptype;
+  scm_port_table[i].port = z;
+  return z;
+}
+SCM scm_open_ports()
+{
+  SCM p, res = EOL;
+  int k;
+  for(k = scm_port_table_len - 1; k > 0; k--) {
+    p = scm_port_table[k].port;
+    if (NIMP(p) && OPPORTP(p))
+      res = cons(p, res);
+  }
+  return res;
 }
 
 SCM markcdr(ptr)
@@ -1888,8 +2097,10 @@ void init_storage(stack_start_ptr, init_heap_size)
 	hplims = (CELLPTR *) must_malloc(2L*sizeof(CELLPTR), s_hplims);
 	if (0L==init_heap_size) init_heap_size = INIT_HEAP_SIZE;
 	j = init_heap_size;
+/*  	printf("j = %u; init_heap_size = %lu\n", j, init_heap_size); */
 	if ((init_heap_size != j) || !init_heap_seg((CELLPTR) malloc(j), j)) {
 	  j = HEAP_SEG_SIZE;
+/*  	  printf("j = %u; HEAP_SEG_SIZE = %lu\n", j, HEAP_SEG_SIZE); */
 	  if (!init_heap_seg((CELLPTR) malloc(j), j))
 	    wta(MAKINUM(j), (char *)NALLOC, s_heap);
 	}
@@ -1897,12 +2108,37 @@ void init_storage(stack_start_ptr, init_heap_size)
 	heap_org = CELL_UP(hplims[0]);
 		/* hplims[0] can change. do not remove heap_org */
 
-	NEWCELL(def_inp);
-	CAR(def_inp) = scm_port_entry(tc16_fport, OPN|RDNG);
-	SETSTREAM(def_inp, stdin);
-	NEWCELL(def_outp);
-	CAR(def_outp) = scm_port_entry(tc16_fport, OPN|WRTNG|TRACKED);
-	SETSTREAM(def_outp, stdout);
+	scm_port_table_len = 16;
+	scm_port_table = (port_info *)
+	  must_malloc((long)scm_port_table_len * sizeof(port_info), s_port_table);
+	for (j = 0; j < scm_port_table_len; j++) {
+	  scm_port_table[j].flags = 0L;
+	  scm_port_table[j].data = UNDEFINED;
+	  scm_port_table[j].port = UNDEFINED;
+	}
+
+	nullstr = must_malloc_cell(1L, MAKE_LENGTH(0, tc7_string), s_string);
+	CHARS(nullstr)[0] = 0;
+	nullvect = must_malloc_cell(1L, MAKE_LENGTH(0, tc7_vector), s_vector);
+	{
+	  long i = symhash_dim;
+	  SCM *velts;
+	  symhash = must_malloc_cell(i * sizeof(SCM),
+				     MAKE_LENGTH(i, tc7_vector),
+				     s_vector);
+	  velts = VELTS(symhash);
+	  while(--i >= 0) (velts)[i] = EOL;
+	}
+	/* Now that symhash is setup, we can sysintern() */
+	sysintern("most-positive-fixnum", (SCM)MAKINUM(MOST_POSITIVE_FIXNUM));
+	sysintern("most-negative-fixnum", (SCM)MAKINUM(MOST_NEGATIVE_FIXNUM));
+#ifdef BIGDIG
+	sysintern("bignum-radix", MAKINUM(BIGRAD));
+#endif
+	def_inp = scm_port_entry(stdin, tc16_fport, OPN|RDNG);
+	SCM_PORTDATA(def_inp) = CAR(sysintern("stdin", UNDEFINED));
+	def_outp = scm_port_entry(stdout, tc16_fport, OPN|WRTNG|TRACKED);
+	SCM_PORTDATA(def_outp) = CAR(sysintern("stdout", UNDEFINED));
 	NEWCELL(def_errp);
 	CAR(def_errp) = (tc16_fport|OPN|WRTNG);
 	SETSTREAM(def_errp, stderr);
@@ -1922,17 +2158,6 @@ void init_storage(stack_start_ptr, init_heap_size)
 	listofnull = cons(EOL, EOL);
 	undefineds = cons(UNDEFINED, EOL);
 	CDR(undefineds) = undefineds;
-	nullstr = makstr(0L);
-	nullvect = make_vector(INUM0, UNDEFINED);
-	/* NEWCELL(nullvect);
-	   CAR(nullvect) = tc7_vector;
-	   SETCHARS(nullvect, NULL); */
-	symhash = make_vector((SCM)MAKINUM(symhash_dim), EOL);
-	sysintern("most-positive-fixnum", (SCM)MAKINUM(MOST_POSITIVE_FIXNUM));
-	sysintern("most-negative-fixnum", (SCM)MAKINUM(MOST_NEGATIVE_FIXNUM));
-#ifdef BIGDIG
-	sysintern("bignum-radix", MAKINUM(BIGRAD));
-#endif
 	/* flo0 is now setup in scl.c */
 	/* Set up environment cache */
 	scm_ecache_len = sizeof(ecache_v)/sizeof(cell);
@@ -2014,8 +2239,9 @@ jump_buf save_regs_gc_mark;
 void mark_locations P((STACKITEM x[], sizet n));
 static void mark_syms P((SCM v));
 static void mark_sym_values P((SCM v));
-static void mark_subr_table P((void));
+static void mark_subrs P((void));
 static void sweep_symhash P((SCM v));
+static void mark_finalizers P((SCM *live, SCM *dead));
 static void mark_port_table P((SCM port));
 static void sweep_port_table P((void));
 static void egc_mark P((void));
@@ -2032,6 +2258,49 @@ SCM gc(arg)
   ALLOW_INTS;
   return UNSPECIFIED;
 }
+
+void scm_run_finalizers(exiting)
+     int exiting;
+{
+  SCM f;
+  if (exiting) {		/* run all finalizers, we're going home. */
+    DEFER_INTS;
+    while NIMP(gc_finalizers) {
+      f = CAR(gc_finalizers);
+      CAR(f) = CDR(f);
+      CDR(f) = gc_finalizers_pending;
+      gc_finalizers_pending = f;
+      gc_finalizers = CDR(gc_finalizers);
+    }
+    ALLOW_INTS;
+  }
+  while (!0) {
+    DEFER_INTS;
+    if NIMP(gc_finalizers_pending) {
+      f = CAR(gc_finalizers_pending);
+      gc_finalizers_pending = CDR(gc_finalizers_pending);
+    }
+    else f = BOOL_F;
+    ALLOW_INTS;
+    if IMP(f) break;
+    apply(f, EOL, EOL);
+  }
+}
+
+static SCM *loc_gc_hook = 0;
+void scm_gc_hook ()
+{
+  if (gc_hook_active) {
+    scm_warn("gc-hook thrashing?\n", "", UNDEFINED);
+    return;
+  }
+  gc_hook_active = !0;
+  if (! loc_gc_hook) loc_gc_hook = &CDR(sysintern("gc-hook", UNDEFINED));
+  if (NIMP(*loc_gc_hook)) apply(*loc_gc_hook, EOL, EOL);
+  scm_run_finalizers(0);
+  gc_hook_active = 0;
+}
+
 void igc(what, stackbase)
      char *what;
      STACKITEM *stackbase;
@@ -2043,8 +2312,7 @@ void igc(what, stackbase)
   if (err) wta(MAKINUM(err), "malloc corrupted", what);
 #endif
   gc_start(what);
-  if (errjmp_bad)
-    wta(UNDEFINED, s_recursive, s_gc);
+  if (errjmp_bad) wta(UNDEFINED, s_recursive, s_gc);
   errjmp_bad = s_gc;
 #ifdef NO_SYM_GC
   gc_mark(symhash);
@@ -2057,7 +2325,7 @@ void igc(what, stackbase)
   /* mark_sym_values() can be called anytime after mark_syms.  */
   mark_sym_values(symhash);
 #endif
-  mark_subr_table();
+  mark_subrs();
   egc_mark();
   if (stackbase) {
     FLUSH_REGISTER_WINDOWS;
@@ -2088,6 +2356,7 @@ void igc(what, stackbase)
   }
   while(j--)
     gc_mark(sys_protects[j]);
+  mark_finalizers(&gc_finalizers, &gc_finalizers_pending);
 #ifndef NO_SYM_GC
   sweep_symhash(symhash);
 #endif
@@ -2102,12 +2371,15 @@ void igc(what, stackbase)
     growth_mon(s_numheaps, (long)(hplim_ind/2), s_segs, grewp);
     growth_mon(s_heap, heap_cells, s_cells, grewp);
   }
+  gc_hook_pending = !0;
+  deferred_proc = process_signals;
 }
 
 static char s_not_free[] = "not freed";
 void free_storage()
 {
   DEFER_INTS;
+  loc_gc_hook = (SCM *)0;
   gc_start("free");
   errjmp_bad = "free_storage";
   cur_inp = BOOL_F; cur_outp = BOOL_F;
@@ -2137,7 +2409,7 @@ void free_storage()
   hplims = 0;
   scm_free_gra(&finals_gra);
   scm_free_gra(&smobs_gra);
-  scm_free_gra(&subr_table_gra);
+  scm_free_gra(&subrs_gra);
   gc_end();
   ALLOW_INTS; /* A really bad idea, but printing does it anyway. */
   exit_report();
@@ -2302,7 +2574,7 @@ void mark_locations(x, n)
 	register int i, j;
 	register CELLPTR ptr;
 	while(0 <= --m) if CELLP(*(SCM **)&x[m]) {
-		ptr = (CELLPTR)SCM2PTR((*(SCM **)&x[m]));
+		ptr = (CELLPTR)SCM2PTR((SCM)(*(SCM **)&x[m]));
 		i = 0;
 		j = hplim_ind;
 		do {
@@ -2332,10 +2604,10 @@ static void gc_sweep(contin_bad)
   long pre_m = mallocated;
   sizet i = 0;
   sizet seg_cells;
-  while (i<hplim_ind) {
+  while (i < hplim_ind) {
     ptr = CELL_UP(hplims[i++]);
     seg_cells = CELL_DN(hplims[i++]) - ptr;
-    for(j = seg_cells;j--;++ptr) {
+    for(j = seg_cells; j--; ++ptr) {
 #ifdef POINTERS_MUNGED
       scmptr = PTR2SCM(ptr);
 #endif
@@ -2397,12 +2669,8 @@ static void gc_sweep(contin_bad)
 	goto freechars;
       case tc7_contin:
 	if GC8MARKP(scmptr) {
-	  if (contin_bad && CONT(scmptr)->length) {
-	    scm_warn("uncollected ", (char *)0);
-	    iprin1(scmptr, cur_errp, 1);
-	    lputc('\n', cur_errp);
-	    lfflush(cur_errp);
-	  }
+	  if (contin_bad && CONT(scmptr)->length)
+	    scm_warn("uncollected ", "", scmptr);
 	  goto c8mrkcontinue;
 	}
 	minc = LENGTH(scmptr)*sizeof(STACKITEM) + sizeof(CONTINUATION);
@@ -2456,8 +2724,8 @@ static void gc_sweep(contin_bad)
 	  default:
 	    goto sweeperr;
 	  }
-#endif /* def FLOATS */
 	  break;
+#endif /* def FLOATS */
 	default:
 	  if GC8MARKP(scmptr) goto c8mrkcontinue;
 	  {
@@ -2580,10 +2848,59 @@ static void sweep_symhash(v)
 }
 #endif
 
-static void mark_subr_table()
+/* This function should be called after all other marking is done. */
+static void mark_finalizers(finalizers, pending)
+     SCM *finalizers, *pending;
+{
+  SCM lst, elt, v;
+  SCM live = EOL, undead = *finalizers;
+  int more_to_do = !0;
+  gc_mark(*pending);
+  while NIMP(*pending) pending = &CDR(*pending);
+  while (more_to_do) {
+    more_to_do = 0;
+    lst = undead;
+    undead = EOL;
+    while (NIMP(lst)) {
+      elt = CAR(lst);
+      v = CAR(elt);
+      switch (TYP3(v)) {
+      default:
+	if (GCMARKP(v)) goto marked;
+	goto unmarked;
+      case tc3_tc7_types:
+	if (GC8MARKP(v)) {
+	marked:
+	  gc_mark(CDR(elt));
+	  more_to_do = !0;
+	  v = lst;
+	  lst = CDR(lst);
+	  CDR(v) = live;
+	  live = v;
+	}
+	else {
+	unmarked:
+	  v = lst;
+	  lst = CDR(lst);
+	  CDR(v) = undead;
+	  undead = v;
+	}
+	break;
+      }
+    }
+  }
+  gc_mark(live);
+  for (lst = undead; NIMP(lst); lst = CDR(lst))
+    CAR(lst) = CDR(CAR(lst));
+  gc_mark(undead);
+  *finalizers = live;
+  *pending = undead;
+}
+
+static void mark_subrs()
 {
-  subr_info *table = subr_table;
-  int k = subr_table_gra.len;
+  /* subr_info *table = subrs; */
+  /* int k = subrs_gra.len; */
   /* while (k--) { } */
 }
 static void mark_port_table(port)
@@ -2606,7 +2923,8 @@ static void sweep_port_table()
       scm_port_table[k].flags &= (~1L);
     else {
       scm_port_table[k].flags = 0L;
-      scm_port_table[k].data = EOL;
+      scm_port_table[k].data = UNDEFINED;
+      scm_port_table[k].port = UNDEFINED;
     }
   }
 }
@@ -2732,9 +3050,9 @@ static void egc_copy_roots()
 				   non-cache cell was made to point into the
 				   cache. */
       if ECACHEP(x) break;
-      e = CDR(x);
+      e = CAR(x);
       if (NIMP(e) && ECACHEP(e))
-	egc_copy(&(CDR(x)));
+	egc_copy(&(CAR(x)));
       break;
     default:
       if (tc7_contin==TYP7(x)) {