Import Upstream version 5d2upstream/5d2

1 files changed, 735 insertions, 466 deletions

diff --git a/sys.c b/sys.c
index 82ea647..b63cb5e 100644
--- a/sys.c
+++ b/sys.c
@@ -1,18 +1,18 @@
 /* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997 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
  * the Free Software Foundation; either version 2, or (at your option)
  * any later version.
- * 
+ *
  * This program 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 this software; see the file COPYING.  If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ * 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.
@@ -36,7 +36,7 @@
  *
  * If you write modifications of your own for GUILE, it is your choice
  * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.  
+ * If you do not wish that, delete this exception notice.
  */
 
 /* "sys.c" opening and closing files, storage, and GC. */
@@ -114,11 +114,12 @@ char	s_close_port[] = "close-port";
 SCM i_setbuf0(port)		/* should be called with DEFER_INTS active */
      SCM port;
 {
+  VERIFY_INTS("i_setbuf0", 0L);
 #ifndef NOSETBUF
 # ifndef MSDOS
 #  ifdef FIONREAD
 #   ifndef ultrix
-  SYSCALL(setbuf(STREAM(port), 0););
+  SYSCALL(setbuf(STREAM(port), 0L););
 #   endif
 #  endif
 # endif
@@ -126,12 +127,26 @@ SCM i_setbuf0(port)		/* should be called with DEFER_INTS active */
   return UNSPECIFIED;
 }
 
-long mode_bits(modes)
-     char *modes;
-{
-  return OPN | (strchr(modes, 'r') || strchr(modes, '+') ? RDNG : 0)
-    | (strchr(modes, 'w') || strchr(modes, 'a') || strchr(modes, '+') ? WRTNG : 0)
-      | (strchr(modes, '0') ? BUF0 : 0);
+/* The CRDY bit is overloaded to indicate that additional processing
+   is needed when reading or writing, such as updating line and column
+   numbers. */
+long mode_bits(modes, cmodes)
+     char *modes, *cmodes;
+{
+  int iout = 0;
+  long bits = OPN;
+  for (; *modes; modes++)
+    switch (*modes) {
+    case 'r': bits |= RDNG; goto outc;
+    case 'w': case 'a': bits |= WRTNG; goto outc;
+    case '+': bits |= (RDNG | WRTNG); goto outc;
+    case 'b': bits |= BINARY; goto outc;
+    case '0': bits |= BUF0; break;
+    case '?': bits |= (TRACKED | CRDY); break;
+    outc: if (cmodes && (iout < 3)) cmodes[iout++] = *modes; break;
+    }
+  if (cmodes) cmodes[iout] = 0;
+  return bits;
 }
 
 SCM try_open_file(filename, modes)
@@ -139,18 +154,22 @@ SCM try_open_file(filename, modes)
 {
   register SCM port;
   FILE *f;
+  char cmodes[4];
+  long flags = mode_bits(CHARS(modes), cmodes);
   ASSERT(NIMP(filename) && STRINGP(filename), filename, ARG1, s_open_file);
   ASSERT(NIMP(modes) && STRINGP(modes), modes, ARG2, s_open_file);
   NEWCELL(port);
   DEFER_INTS;
-  SYSCALL(f = fopen(CHARS(filename), CHARS(modes)););
-  if (!f) port = BOOL_F;
-  else {
-    SETSTREAM(port, f);
-    if (BUF0 & (CAR(port) = tc16_fport | mode_bits(CHARS(modes))))
-      i_setbuf0(port);
+  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);
+  if (BUF0 & flags) i_setbuf0(port);
   ALLOW_INTS;
+  SCM_PORTDATA(port) = filename;
   return port;
 }
 
@@ -195,7 +214,7 @@ SCM output_portp(x)
 # undef L_tmpnam		/* Not supported in TURBOC V1.0 */
 #endif
 #ifdef GO32
-# undef L_tmpnam
+# undef L_tmpnam		/* Would put files in %TMPDIR% = %DJDIR%/tmp */
 #endif
 #ifdef MWC
 # undef L_tmpnam
@@ -300,24 +319,6 @@ void prinport(exp, port, type)
     else intprint(CDR(exp), -16, port);
   lputc('>', port);
 }
-static int prinfport(exp, port, writing)
-     SCM exp; SCM port; int writing;
-{
-  prinport(exp, port, s_port_type);
-  return !0;
-}
-static int prinstpt(exp, port, writing)
-     SCM exp; SCM port; int writing;
-{
-  prinport(exp, port, s_string);
-  return !0;
-}
-static int prinsfpt(exp, port, writing)
-     SCM exp; SCM port; int writing;
-{
-  prinport(exp, port, "soft");
-  return !0;
-}
 
 static int stputc(c, p)
      int c; SCM p;
@@ -374,7 +375,7 @@ SCM mkstrport(pos, str, modes, caller)
   NEWCELL(z);
   DEFER_INTS;
   SETCHARS(z, str);
-  CAR(z) = tc16_strport | modes;
+  CAR(z) = scm_port_entry(tc16_strport, modes);
   ALLOW_INTS;
   return z;
 }
@@ -412,9 +413,10 @@ sizet pwrite(ptr, size, nitems, port)
 #endif
 
 static ptobfuns fptob = {
+  s_port_type,
   mark0,
   fclose,
-  prinfport,
+  0,
   0,
   fputc,
 #ifdef __MWERKS__
@@ -428,9 +430,10 @@ static ptobfuns fptob = {
   fgetc,
   fclose};
 ptobfuns pipob = {
+  0,
   mark0,
-  0, 				/* replaced by pclose in init_ioext() */
-  0, 				/* replaced by prinpipe in init_ioext() */
+  0,				/* replaced by pclose in init_ioext() */
+  0,
   0,
   fputc,
 #ifdef __MWERKS__
@@ -441,19 +444,20 @@ ptobfuns pipob = {
   ffwrite,
 #endif
   fflush,
-  fgetc,
-  0};				/* replaced by pclose in init_ioext() */
+  fgetc};
 static ptobfuns stptob = {
+  s_string,
   markcdr,
   noop0,
-  prinstpt,
+  0,
   0,
   stputc,
   stputs,
   stwrite,
   noop0,
   stgetc,
-  0};
+  0};				/* stungetc */
+
 
 				/* Soft ports */
 
@@ -465,7 +469,8 @@ static ptobfuns stptob = {
 static int sfputc(c, p)
      int c; SCM p;
 {
-  apply(VELTS(p)[0], MAKICHR(c), listofnull);
+  SCM arg = MAKICHR(c);
+  scm_cvapply(VELTS(p)[0], 1L, &arg);
   errno = 0;
   return c;
 }
@@ -475,7 +480,7 @@ sizet sfwrite(str, siz, num, p)
 {
   SCM sstr;
   sstr = makfromstr(str, siz * num);
-  apply(VELTS(p)[1], sstr, listofnull);
+  scm_cvapply(VELTS(p)[1], 1L, &sstr);
   errno = 0;
   return num;
 }
@@ -498,7 +503,7 @@ static int sfgetc(p)
      SCM p;
 {
   SCM ans;
-  ans = apply(VELTS(p)[3], EOL, EOL);
+  ans = scm_cvapply(VELTS(p)[3], 0L, (SCM *)0);
   errno = 0;
   if (FALSEP(ans) || EOF_VAL==ans) return EOF;
   ASSERT(ICHRP(ans), ans, ARG1, "getc");
@@ -518,20 +523,31 @@ SCM mksfpt(pv, modes)
      SCM pv, modes;
 {
   SCM z;
-  ASSERT(NIMP(pv) && VECTORP(pv) && 5==LENGTH(pv), pv, ARG1, s_mksfpt);
+  static long arities[] = {1, 1, 0, 0, 0};
+#ifndef RECKLESS
+  int i;
+  if (! (NIMP(pv) && VECTORP(pv) && 5==LENGTH(pv)))
+    badarg: wta(pv, (char *)ARG1, s_mksfpt);
+  for (i = 0; i < 5; i++) {
+    ASRTGO(FALSEP(VELTS(pv)[i]) ||
+	   scm_arity_check(VELTS(pv)[i], arities[i], (char *)0),
+	   badarg);
+  }
+#endif
   ASSERT(NIMP(modes) && STRINGP(modes), modes, ARG2, s_mksfpt);
   NEWCELL(z);
   DEFER_INTS;
-  CAR(z) = tc16_sfport | mode_bits(CHARS(modes));
+  CAR(z) = scm_port_entry(tc16_sfport, mode_bits(CHARS(modes), (char *)0));
   SETSTREAM(z, pv);
   ALLOW_INTS;
   return z;
 }
 
 static ptobfuns sfptob = {
+  "soft",
   markcdr,
   noop0,
-  prinsfpt,
+  0,
   0,
   sfputc,
   sfputs,
@@ -567,7 +583,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) {
-	warn("output buffer", " overflowed");
+	scm_warn("output buffer", " overflowed");
 	intprint((long)errbuf_end, 10, cur_errp);
 	lputs(" chars needed\n", cur_errp);
 	errbuf_end = errbuf_end % SYS_ERRP_SIZE;
@@ -603,6 +619,7 @@ static int sysflush(p)
   return 0;
 }
 static ptobfuns sysptob = {
+  0,
   mark0,
   noop0,
   0,
@@ -614,6 +631,105 @@ static ptobfuns sysptob = {
   noop0,
   noop0};
 
+/* A `safeport' is used for writing objects as part of an error response.
+   Since these objects may be very large or circular, the safeport will
+   output only a fixed number of characters before exiting via longjmp.
+   A setjmp must be done before each use of the safeport. */
+
+static char s_msp[] = "mksafeport";
+int tc16_safeport;
+SCM mksafeport(maxlen, port)
+     int maxlen;
+     SCM port;
+{
+  SCM z;
+  if UNBNDP(port) port = cur_errp;
+  else {
+    ASSERT(NIMP(port) && OPPORTP(port), port, ARG2, s_msp);
+  }
+  DEFER_INTS;
+  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)
+     int maxlen;
+     SCM sfp, port;
+{
+  if (NIMP(sfp) && tc16_safeport==TYP16(sfp)) {
+    ((safeport *)STREAM(sfp))->ccnt = maxlen;
+    if NIMP(port)
+      ((safeport *)STREAM(sfp))->port = port;
+    return !0;
+  }
+  return 0;
+}
+static sizet safewrite(str, siz, num, p)
+     sizet siz, num;
+     char *str; safeport *p;
+{
+  int count = p->ccnt;
+  sizet n = siz*num;
+  if (n < count) {
+    p->ccnt = count - n;
+    lfwrite(str, siz, num, p->port);
+  }
+  else if (count) {
+    num = count / siz;
+    p->ccnt = 0;
+    lfwrite(str, siz, num, p->port);
+    lputs(" ...", p->port);
+    longjmp(p->jmpbuf, !0);	/* The usual C longjmp, not SCM's longjump */
+  }
+  return siz;
+}
+static int safeputs(s, p)
+     char *s; safeport *p;
+{
+  safewrite(s, 1, strlen(s), p);
+  return 0;
+}
+static int safeputc(c, p)
+     int c; safeport *p;
+{
+  char cc = c;
+  safewrite(&cc, 1, 1, p);
+  return c;
+}
+static int safeflush(p)
+     safeport *p;
+{
+  lflush(p->port);
+  return 0;
+}
+static SCM marksafep(ptr)
+     SCM ptr;
+{
+  return ((safeport *)STREAM(ptr))->port;
+}
+static int freesafep(ptr)
+     FILE *ptr;
+{
+  must_free((char *)ptr, sizeof(safeport));
+  return 0;
+}
+static ptobfuns safeptob = {
+  0,
+  marksafep,
+  freesafep,
+  0,
+  0,
+  safeputc,
+  safeputs,
+  safewrite,
+  safeflush,
+  noop0,
+  noop0};
+
 static int freeprint(exp, port, writing)
      SCM exp; SCM port; int writing;
 {
@@ -644,48 +760,72 @@ static smobfuns flob = {
   mark0,
   /*flofree*/0,
   floprint,
-  floequal};
+#ifdef FLOATS
+  floequal
+#else
+  0
+#endif
+};
 static smobfuns bigob = {
   mark0,
   /*bigfree*/0,
   bigprint,
-  bigequal};
-void (**finals)() = 0;
-sizet num_finals = 0;
+#ifdef BIGDIG
+  bigequal
+#else
+  0
+#endif
+};
+
+scm_gra finals_gra;
 static char s_final[] = "final";
 
+/* statically allocated ports for diagnostic messages */
+static cell tmp_errpbuf[3];
+static SCM tmp_errp;
+extern sizet num_protects;	/* sys_protects now in scl.c */
 void init_types()
 {
-  numptob = 0;
-  ptobs = (ptobfuns *)malloc(4*sizeof(ptobfuns));
+  sizet j = num_protects;
+  /* Because not all protects may get initialized */
+  while(j) sys_protects[--j] = BOOL_F;
+
+  /* We need to set up tmp_errp before any errors may be
+     thrown, the port_table index will be zero, usable
+     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);
+  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");
   /* 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_sysport = newptob(&sysptob);
-  numsmob = 0;
-  smobs = (smobfuns *)malloc(7*sizeof(smobfuns));
+  tc16_safeport = newptob(&safeptob);
+  scm_init_gra(&smobs_gra, sizeof(smobfuns), 7, 255, "smobs");
   /* These newsmob calls must be done in this order */
   newsmob(&freecell);
   newsmob(&flob);
   newsmob(&bigob);
   newsmob(&bigob);
-  finals = (void(**)())malloc(2 * sizeof(finals[0]));
-  num_finals = 0;
+  scm_init_gra(&finals_gra, sizeof(void (*)()), 2, 0, s_final);
 }
 
+#ifdef TEST_FINAL
+void test_final()
+{
+  fputs("test_final ok\n", stderr);
+}
+#endif
 void add_final(final)
      void (* final)();
 {
-  DEFER_INTS;
-  finals = (void (**)()) must_realloc((char *)finals,
-				      (long)(num_finals)*sizeof(finals[0]),
-				      (1L+num_finals)*sizeof(finals[0]),
-				      s_final);
-  finals[num_finals++] = final;
-  ALLOW_INTS;
-  return;
+  scm_grow_gra(&finals_gra, (char *)&final);
 }
 
 static char s_estk[] = "environment stack";
@@ -694,100 +834,131 @@ SCM scm_egc_roots[ECACHE_SIZE/20];
 CELLPTR scm_ecache;
 VOLATILE long scm_ecache_index, scm_ecache_len, scm_egc_root_index;
 SCM scm_estk = UNDEFINED, *scm_estk_ptr;
-void scm_estk_reset()
+static SCM estk_pool = EOL;
+long scm_estk_size;
+static SCM make_stk_seg(size, contents)
+     sizet size;
+     SCM contents;
 {
-  SCM nstk = scm_estk, *v;
+  SCM seg = BOOL_F, *src, *dst;
   sizet i;
-  VERIFY_INTS("scm_estk_reset", 0);
-  /* We might be here because we blew the stack, or got tired of
-     watching it grow, so make sure the stack size is sane. */
-  if (IMP(nstk) || 50*SCM_ESTK_FRLEN < LENGTH(nstk)) {
-    i = 50L*SCM_ESTK_FRLEN + 1;
-    nstk = must_malloc_cell((long)i*sizeof(SCM), s_estk);
-    SETLENGTH(nstk, i, tc7_vector);
+  VERIFY_INTS("make_stk_seg", 0L);
+  while NIMP(estk_pool) {
+    if (size==LENGTH(estk_pool)) {
+      seg = estk_pool;
+      estk_pool = SCM_ESTK_PARENT(seg);
+      break;
+    }
+    estk_pool = SCM_ESTK_PARENT(estk_pool);
+  }
+  if IMP(seg) seg = must_malloc_cell((long)size*sizeof(SCM),
+				     MAKE_LENGTH(size, tc7_vector), s_estk);
+  dst = VELTS(seg);
+  if NIMP(contents) {
+    src = VELTS(contents);
+    for (i = size; i--;) dst[i] = src[i];
+  }
+  else {
+    for (i = size; i--;) dst[i] = UNSPECIFIED;
+    SCM_ESTK_PARENT(seg) = BOOL_F;
+    SCM_ESTK_PARENT_INDEX(seg) = INUM0;
+    dst[SCM_ESTK_BASE - 1] = UNDEFINED;	 /* underflow sentinel */
+  }
+  dst[size - 1] = UNDEFINED;	/* overflow sentinel */
+  return seg;
+}
+/* size is a number of SCM elements, or zero for a default size.
+   If nonzero, size must be SCM_ESTK_BASE + N * SCM_ESTK_FRLEN + 1
+   for some reasonable number of stackframes N  */
+void scm_estk_reset(size)
+     sizet size;
+{
+  VERIFY_INTS("scm_estk_reset", 0L);
+  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;
+}
+void scm_estk_grow()
+{
+  /* 40 and 10 below are adjustable parameters:  the number of frames
+     in a stack segment, and the number of frames to overlap between
+     stack segments. */
+  sizet size = 40 * SCM_ESTK_FRLEN + SCM_ESTK_BASE + 1;
+  sizet overlap = 10*SCM_ESTK_FRLEN;
+  SCM estk = make_stk_seg(size, UNDEFINED);
+  SCM *newv, *oldv;
+  sizet i, j;
+  newv = VELTS(estk);
+  oldv = VELTS(scm_estk);
+  j = scm_estk_ptr - VELTS(scm_estk) + 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);
+  for (i = SCM_ESTK_BASE; i < SCM_ESTK_BASE + overlap; i++, j++) {
+    newv[i] = oldv[j];
+    oldv[j] = BOOL_F;
   }
-  i = LENGTH(nstk);
-  v = VELTS(nstk);
-  while (i--) v[i] = UNSPECIFIED;
-  v[LENGTH(nstk)-1] = INUM0;	/* overflow sentinel */
-  v[0] = INUM0;			/* underflow sentinel */
-				/* The following are for a (future) segmented 
-				   stack implementation. */
-  v[1] = BOOL_T;		/* writable? */
-  v[SCM_ESTK_FRLEN] = EOL;	/* Must look like an environment */
-  v[SCM_ESTK_FRLEN + 1] = EOL; /* next stack segment */
-  scm_estk = nstk;
-  scm_estk_ptr = &(v[SCM_ESTK_BASE - SCM_ESTK_FRLEN]);
-}
-
-void scm_estk_grow(inc)
-     sizet inc;
-{
-  SCM estk = make_vector(MAKINUM(LENGTH(scm_estk) + inc*SCM_ESTK_FRLEN),
-			 UNSPECIFIED);
-  sizet n, i;
-  DEFER_INTS;
-  n = scm_estk_ptr - VELTS(scm_estk);
-  ASSERT(n<=LENGTH(scm_estk), UNDEFINED, "estk corrupted", "scm_estk_grow");
-  for (i = n + 1; i--;)
-    VELTS(estk)[i] = VELTS(scm_estk)[i];
-				/* Sentinel for stack overflow. */
-  VELTS(estk)[LENGTH(estk)-1] = INUM0;
   scm_estk = estk;
-  scm_estk_ptr = &(VELTS(estk)[n + SCM_ESTK_FRLEN]);
-  ALLOW_INTS;
-  growth_mon(s_estk, LENGTH(scm_estk), "locations", !0);
+  scm_estk_ptr = &(newv[SCM_ESTK_BASE + overlap]);
+  scm_estk_size += size;
+  /*  growth_mon(s_estk, scm_estk_size, "locations", !0); */
 }
-
-/* Will be useful when segmented stack is implemented. */
 void scm_estk_shrink()
 {
-#if 0
-  SCM next = VELTS(scm_estk)[SCM_ESTK_FRLEN];
-  int istrt;
-  if IMP(next) wta(UNDEFINED, "underflow", "stack");
-  istrt = INUM(CDR(next));
-  next = CAR(next);
-  if (BOOL_T != VELTS(next)[1]) {
-    SCM new_estk = make_vector(MAKINUM(LENGTH(scm_estk)), UNSPECIFIED);
-    int i = istrt;
-    while (--i) VELTS(new_estk)[i] = VELTS(next)[i];
-    VELTS(new_estk)[1] = BOOL_T;
-    VELTS(new_estk)[LENGTH(new_estk)-1] = INUM0;
-    next = new_estk;
-  }
-  scm_estk = next;
-  scm_estk_ptr = &(VELTS(scm_estk)[istrt]);
-#else
-  wta(UNDEFINED, "underflow", s_estk);
-#endif
+  SCM parent, *v;
+  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);
+  SCM_ESTK_PARENT(scm_estk) = estk_pool;
+  estk_pool = scm_estk;
+  scm_estk_size -= LENGTH(scm_estk);
+  scm_estk = parent;
+  scm_estk_ptr = &(VELTS(parent)[i]);
+  /*  growth_mon(s_estk, scm_estk_size, "locations", 0); */
 }
 
 void scm_env_cons(x, y)
      SCM x, y;
 {
    register SCM z;
+   register int i;
    DEFER_INTS_EGC;
-   if (1>scm_ecache_index) scm_egc();
-   z = PTR2SCM(&(scm_ecache[--scm_ecache_index]));
+   i = scm_ecache_index;
+   if (1>i) {
+     scm_egc();
+     i = scm_ecache_index;
+   }
+   z = PTR2SCM(&(scm_ecache[--i]));
    CAR(z) = x;
    CDR(z) = y;
    scm_env_tmp = z;
+   scm_ecache_index = i;
 }
 
 void scm_env_cons2(w, x, y)
      SCM w, x, y;
 {
    SCM z1, z2;
+   register int i;
    DEFER_INTS_EGC;
-   if (2>scm_ecache_index) scm_egc();
-   z1 = PTR2SCM(&(scm_ecache[--scm_ecache_index]));
+   i = scm_ecache_index;
+   if (2>i) {
+     scm_egc();
+     i = scm_ecache_index;
+   }
+   z1 = PTR2SCM(&(scm_ecache[--i]));
    CAR(z1) = x;
    CDR(z1) = y;
-   z2 = PTR2SCM(&(scm_ecache[--scm_ecache_index]));
+   z2 = PTR2SCM(&(scm_ecache[--i]));
    CAR(z2) = w;
    CDR(z2) = z1;
-   scm_env_tmp = z2; 
+   scm_env_tmp = z2;
+   scm_ecache_index = i;
 }
 
 /* scm_env_tmp = cons(x, scm_env_tmp) */
@@ -795,12 +966,41 @@ void scm_env_cons_tmp(x)
      SCM x;
 {
    register SCM z;
+   register int i;
    DEFER_INTS_EGC;
-   if (1>scm_ecache_index) scm_egc();
-   z = PTR2SCM(&(scm_ecache[--scm_ecache_index]));
+   i = scm_ecache_index;
+   if (1>i) {
+     scm_egc();
+     i = scm_ecache_index;
+   }
+   z = PTR2SCM(&(scm_ecache[--i]));
    CAR(z) = x;
    CDR(z) = scm_env_tmp;
    scm_env_tmp = z;
+   scm_ecache_index = i;
+}
+
+void scm_env_v2lst(argc, argv)
+     int argc;
+     SCM *argv;
+{
+   SCM z1, z2;
+   register int i;
+   DEFER_INTS_EGC;
+   i = scm_ecache_index;
+   if (argc>i) {
+     scm_egc();
+     i = scm_ecache_index;
+   }
+   z1 = z2 = scm_env_tmp;	/* set z1 just in case argc is zero */
+   while (argc--) {
+     z1 = PTR2SCM(&(scm_ecache[--i]));
+     CAR(z1) = argv[argc];
+     CDR(z1) = z2;
+     z2 = z1;
+   }
+   scm_env_tmp = z1;
+   scm_ecache_index = i;
 }
 
 /* scm_env = acons(names, scm_env_tmp, scm_env) */
@@ -808,15 +1008,21 @@ void scm_extend_env(names)
      SCM names;
 {
    SCM z1, z2;
+   register int i;
    DEFER_INTS_EGC;
-   if (2>scm_ecache_index) scm_egc();
-   z1 = PTR2SCM(&(scm_ecache[--scm_ecache_index]));
+   i = scm_ecache_index;
+   if (2>i) {
+     scm_egc();
+     i = scm_ecache_index;
+   }
+   z1 = PTR2SCM(&(scm_ecache[--i]));
    CAR(z1) = names;
    CDR(z1) = scm_env_tmp;
-   z2 = PTR2SCM(&(scm_ecache[--scm_ecache_index]));
+   z2 = PTR2SCM(&(scm_ecache[--i]));
    CAR(z2) = z1;
    CDR(z2) = scm_env;
    scm_env = z2;
+   scm_ecache_index = i;
 }
 char s_obunhash[] = "object-unhash", s_cache_gc[] = "cache_gc";
 char s_recursive[] = "recursive";
@@ -853,10 +1059,13 @@ void init_io()
   init_iprocs(subr2s, tc7_subr_2);
   loc_open_file =
     &CDR(sysintern(s_open_file,
-		   CDR(intern(s_try_open_file, sizeof(s_try_open_file)-1))));
+		   CDR(sysintern(s_try_open_file, UNDEFINED))));
 #ifndef CHEAP_CONTINUATIONS
   add_feature("full-continuation");
 #endif
+#ifdef TEST_FINAL
+  add_final(test_final);
+#endif
 }
 
 void grew_lim(nm)
@@ -869,9 +1078,9 @@ sizet hplim_ind = 0;
 long heap_cells = 0;
 CELLPTR *hplims, heap_org;
 VOLATILE SCM freelist = EOL;
-long mtrigger, mltrigger;
+long mltrigger, mtrigger = INIT_MALLOC_LIMIT;
 
-/* Ints should be deferred when calling igc_for_malloc. */
+/* Ints should be deferred when calling igc_for_alloc. */
 static char *igc_for_alloc(where, olen, size, what)
      char *where;
      long olen;
@@ -880,6 +1089,8 @@ 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);
   igc(what, CONT(rootcont)->stkbse);
   nm = mallocated + size - olen;
   if (nm > mltrigger) {
@@ -896,6 +1107,7 @@ static char *igc_for_alloc(where, olen, size, what)
     else mtrigger += mtrigger/2;
     mltrigger = mtrigger - MIN_MALLOC_YIELD;
   }
+  mallocated = nm;
   return ptr;
 }
 char *must_malloc(len, what)
@@ -906,17 +1118,22 @@ char *must_malloc(len, what)
   sizet size = len;
   long nm = mallocated + size;
   VERIFY_INTS("must_malloc", 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(0, 0, size, what);
-  mallocated = nm;
+  if (!ptr)
+    ptr = igc_for_alloc(0L, 0L, size, what);
+  else
+    mallocated = nm;
   return ptr;
 }
-SCM must_malloc_cell(len, what)
+SCM must_malloc_cell(len, c, what)
      long len;
+     SCM c;
      char *what;
 {
   SCM z;
@@ -924,15 +1141,20 @@ SCM must_malloc_cell(len, what)
   sizet size = len;
   long nm = mallocated + size;
   VERIFY_INTS("must_malloc_cell", what);
+#ifdef SHORT_SIZET
   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(0, 0, size, what);
-  mallocated = nm;
+  if (!ptr)
+    ptr = igc_for_alloc(0L, 0L, size, what);
+  else
+    mallocated = nm;
   SETCHARS(z, ptr);
+  CAR(z) = c;
   return z;
 }
 char *must_realloc(where, olen, len, what)
@@ -944,13 +1166,17 @@ char *must_realloc(where, olen, len, what)
   sizet size = len;
   long nm = mallocated + size - olen;
   VERIFY_INTS("must_realloc", 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);
-  mallocated = nm;
+  if (!ptr)
+    ptr = igc_for_alloc(where, olen, size, what);
+  else
+    mallocated = nm;
   return ptr;
 }
 void must_realloc_cell(z, olen, len, what)
@@ -962,13 +1188,17 @@ void must_realloc_cell(z, olen, len, what)
   sizet size = len;
   long nm = mallocated + size - olen;
   VERIFY_INTS("must_realloc_cell", 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);
-  mallocated = nm;
+  if (!ptr)
+    ptr = igc_for_alloc(where, olen, size, what);
+  else
+    mallocated = nm;
   SETCHARS(z, ptr);
 }
 void must_free(obj, len)
@@ -980,124 +1210,11 @@ void must_free(obj, len)
     while (len--) obj[len] = '#';
 #endif
     free(obj);
+    mallocated = mallocated - len;
   }
   else wta(INUM0, "already free", "");
 }
 
-#ifdef NUM_HP
-# define NUM_HP_SIZE 240*sizeof(double)
-
-struct num_hp {
-  struct num_hp *next;  /* Next heap in list */
-  sizet size; /* Size of one half-heap, in doubles */
-  sizet offset;  /* 0 or size, depending on which half-heap is in use */
-  sizet ind;	 /* index of next available double */
-  double hp[1];	 /* Make sure we are optimally aligned for doubles, more
-		    follow */
-};
-typedef struct num_hp num_hp;
-static num_hp *num_hp_head = 0, *num_hp_cur = 0;
-long num_hp_total = 0;
-
-/* size is in bytes */
-static char s_num_hp[] = "flonum/bignum heap";
-static void num_hp_add(size)
-     sizet size;
-{
-  num_hp *new_hp;
-  sizet dsz = size / sizeof(double);
- tail:
-  new_hp = (num_hp_cur ? num_hp_cur->next : 0);
-  if (new_hp) {
-    new_hp->ind = new_hp->size;
-    num_hp_cur = new_hp;
-    return; 
-  }
-  new_hp = (num_hp *)must_malloc(sizeof(num_hp) + (2*dsz-1)*sizeof(double), 
-				 s_num_hp);
-  num_hp_total += sizeof(num_hp) + (2*dsz-1)*sizeof(double) ;
-  growth_mon(s_num_hp, num_hp_total, "doubles", !0);
-  new_hp->next = 0;
-  new_hp->size = dsz;
-  new_hp->offset = 0;
-  new_hp->ind = new_hp->size;
-  /* must_malloc might have called gc, moving num_hp_cur. */
-  if (num_hp_cur) {
-    num_hp *hp = num_hp_cur;
-    while (hp->next) hp = hp->next;
-    hp->next = new_hp;
-  }
-  else 
-    num_hp_cur = new_hp;
-  if (num_hp_cur->ind >= NUM_HP_MAX_REQ/sizeof(double)) return;
-  goto tail;
-}
-
-static void num_hp_switch()
-{
-  num_hp *hp = num_hp_head;
-  while (hp) {
-    hp->offset = (hp->offset + hp->size) % (2*hp->size);
-    hp->ind = hp->size;
-    hp = hp->next;
-  }
-  num_hp_cur = num_hp_head;
-}
-
-/* len is in bytes */
-char *num_hp_alloc(len)
-     sizet len;
-{
-  num_hp *hp = num_hp_cur;
-  len = (len + sizeof(double) - 1)/sizeof(double);
-  if ((!hp) || (hp->ind < NUM_HP_MAX_REQ/sizeof(double))) {
-    num_hp_add(NUM_HP_SIZE);
-    hp = num_hp_cur;
-  }
-  hp->ind -= len;
-  return (char *)&(hp->hp[hp->ind + hp->offset]);
-}
-
-char *num_hp_realloc(where, olen, len, what)
-     char *where, *what;
-     long olen, len;
-{
-  char *ret;
-  sizet i;
-  if (len <= NUM_HP_MAX_REQ) {
-    num_hp *hp = num_hp_cur;
-    if (len <= olen) return where;    
-    if (!hp || (hp->ind < NUM_HP_MAX_REQ/sizeof(double))) {
-      num_hp_add(NUM_HP_SIZE);
-      hp = num_hp_cur;
-    }
-    hp->ind -= (len + sizeof(double) - 1)/sizeof(double);
-    ret = (char *)&(hp->hp[hp->ind + hp->offset]);
-    for (i = len; i--;)
-      ret[i] = where[i];
-    if (olen > NUM_HP_MAX_REQ) must_free(where, (long)olen);
-    return ret;
-  }
-  if (olen > NUM_HP_MAX_REQ) 
-    return must_realloc(where, olen, len, what);
-  ret = must_malloc((long)len, what);
-  for (i = len; i--;)
-    ret[i] = where[i];
-  return ret;
-}
-void num_hp_free(hp)
-     num_hp *hp;
-{
-  num_hp *next;
-  while (hp) {
-    next = hp->next;
-    num_hp_total -= 2*hp->size;
-    must_free((char *)hp, sizeof(num_hp) + hp->size*2 - sizeof(double));
-    hp = next;
-  }
-}
-#endif /* NUM_HP */
-
 SCM symhash;			/* This used to be a sys_protect, but
 				   Radey Shouman <shouman@zianet.com>
 				   added GC for unused, UNDEFINED
@@ -1126,21 +1243,25 @@ 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); */
+  DEFER_INTS;
   for(lsym = VELTS(symhash)[hash];NIMP(lsym);lsym = CDR(lsym)) {
     z = CAR(lsym);
     z = CAR(z);
     tmp = UCHARS(z);
     if (LENGTH(z) != len) goto trynext;
     for(i = len;i--;) if (((unsigned char *)name)[i] != tmp[i]) goto trynext;
+    ALLOW_INTS;
     return CAR(lsym);
   trynext: ;
   }
-  lsym = makfromstr(name, len);
-  DEFER_INTS;
-  SETLENGTH(lsym, (long)len, tc7_msymbol);
-  ALLOW_INTS;
+  /*  lsym = makfromstr(name, len); */
+  lsym = must_malloc_cell(len+1L,
+			  MAKE_LENGTH((long)len, tc7_msymbol), s_string);
+  i = len;
+  CHARS(lsym)[len] = 0;
+  while (i--) CHARS(lsym)[i] = name[i];
   z = acons(lsym, UNDEFINED, UNDEFINED);
-  DEFER_INTS;			/* Operations on symhash must be atomic. */
   CDR(z) = VELTS(symhash)[hash];
   VELTS(symhash)[hash] = z;
   z = CAR(z);
@@ -1163,7 +1284,8 @@ 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);
-    CDR(lsym) = val;
+    if (!UNBNDP(val))
+      CDR(lsym) = val;
     return lsym;
   trynext: ;
   }
@@ -1218,40 +1340,64 @@ SCM makstr(len)
      long len;
 {
 	SCM s;
+#ifndef SHORT_SIZET
+	ASSERT(!(len & ~LENGTH_MAX), MAKINUM(len), NALLOC, s_string);
+#endif
 	DEFER_INTS;
-	s = must_malloc_cell(len+1, s_string);
-	SETLENGTH(s, len, tc7_string);
+	s = must_malloc_cell(len+1L, MAKE_LENGTH(len, tc7_string), s_string);
 	CHARS(s)[len] = 0;
-   	ALLOW_INTS;
+	ALLOW_INTS;
 	return s;
 }
 
-SCM make_subr(name, type, fcn)
+scm_gra subr_table_gra;
+SCM scm_maksubr(name, type, fcn)
      const char *name;
      int type;
      SCM (*fcn)();
 {
-	SCM symcell = sysintern(name, UNDEFINED);
-	long tmp = ((((CELLPTR)(CAR(symcell)))-heap_org)<<8);
+	subr_info info;
+	int isubr;
 	register SCM z;
-	if ((tmp>>8) != ((CELLPTR)(CAR(symcell))-heap_org))
-	  tmp = 0;
+	info.name = name;
+	isubr = scm_grow_gra(&subr_table_gra, (char *)&info);
 	NEWCELL(z);
-	CAR(z) = tmp + type;
+	if (!fcn && tc7_cxr==type) {
+	  const char *p = name;
+	  int code = 0;
+	  while (*++p != 'r')
+	    switch (*p) {
+	    default: wta(UNDEFINED, "bad cxr name", (char *)name);
+	    case 'a': code = (code<<2) + 1; continue;
+	    case 'd': code = (code<<2) + 2; continue;
+	    }
+	  type += (code << 8);
+	}
+	CAR(z) = (isubr<<16) + type;
 	SUBRF(z) = fcn;
-	CDR(symcell) = z;
 	return z;
 }
+SCM make_subr(name, type, fcn)
+     const char *name;
+     int type;
+     SCM (*fcn)();
+{
+	return CDR(sysintern(name, scm_maksubr(name, type, fcn)));
+}
 
 #ifdef CCLO
+char s_comp_clo[] = "compiled-closure";
 SCM makcclo(proc, len)
      SCM proc;
      long len;
 {
   SCM s;
+# ifndef SHORT_SIZET
+  ASSERT(len < (((unsigned long)-1L)>>16), UNDEFINED, NALLOC, s_comp_clo);
+# endif
   DEFER_INTS;
-  s = must_malloc_cell(len*sizeof(SCM), "compiled-closure");
-  SETNUMDIGS(s, len, tc16_cclo);
+  s = must_malloc_cell(len*sizeof(SCM), MAKE_NUMDIGS(len, tc16_cclo),
+		       s_comp_clo);
   while (--len) VELTS(s)[len] = UNSPECIFIED;
   CCLO_SUBR(s) = proc;
   ALLOW_INTS;
@@ -1298,14 +1444,14 @@ SCM dynwind(thunk1, thunk2, thunk3)
   apply(thunk3, EOL, EOL);
   return ans;
 }
-void dowinds(to, delta)
+void downd(to, delta)
      SCM to;
      long delta;
 {
  tail:
   if (dynwinds==to);
   else if (0 > delta) {
-    dowinds(CDR(to), 1+delta);
+    downd(CDR(to), 1+delta);
     apply(CAR(CAR(to)), EOL, EOL);
     dynwinds = to;
   }
@@ -1313,61 +1459,80 @@ void dowinds(to, delta)
     SCM from = CDR(CAR(dynwinds));
     dynwinds = CDR(dynwinds);
     apply(from, EOL, EOL);
-    delta--; goto tail;		/* dowinds(to, delta-1); */
+    delta--; goto tail;		/* downd(to, delta-1); */
   }
 }
+void dowinds(to)
+     SCM to;
+{
+  downd(to,  ilength(dynwinds) - ilength(to));
+}
 
 /* Remember that setjump needs to be called after scm_make_cont */
 
 SCM scm_make_cont()
 {
-  SCM cont, env, *from, *to;
+  SCM cont, estk, *from;
   CONTINUATION *ncont;
   sizet n;
-  VERIFY_INTS("scm_make_cont", 0);
+  VERIFY_INTS("scm_make_cont", 0L);
   NEWCELL(cont);
   from = VELTS(scm_estk);
-  n = scm_estk_ptr - from + SCM_ESTK_FRLEN + 2;
-  env = must_malloc_cell((long)n*sizeof(SCM), s_cont);
-  SETLENGTH(env, (long)n, tc7_vector); 
-  to = VELTS(env);
-  to[--n] = scm_env;
-  to[--n] = scm_env_tmp;
-  while(n--) to[n] = from[n];
+  n = scm_estk_ptr - from + SCM_ESTK_FRLEN;
+#ifdef CHEAP_CONTINUATIONS
+  estk = scm_estk;
+#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);
+  {
+    SCM *to = VELTS(estk);
+    while(n--) to[n] = from[n];
+  }
+#endif
   ncont = make_continuation(CONT(rootcont));
   if (!ncont) wta(MAKINUM(-1), (char *)NALLOC, s_cont);
   ncont->other.parent = rootcont;
   SETCONT(cont, ncont);
   SETLENGTH(cont, ncont->length, tc7_contin);
   ncont->other.dynenv = dynwinds;
-  ncont->other.env = env;
+  ncont->other.stkframe[0] = scm_env;
+  ncont->other.stkframe[1] = scm_env_tmp;
+  ncont->other.estk = estk;
+  ncont->other.estk_ptr = scm_estk_ptr;
   return cont;
 }
 static char s_sstale[] = "strangely stale";
-void scm_dynthrow(cont, val)
-     CONTINUATION *cont;
+void scm_dynthrow(tocont, val)
+     SCM tocont;
      SCM val;
 {
+  CONTINUATION *cont = CONT(tocont);
   if (cont->stkbse != CONT(rootcont)->stkbse)
-    wta(cont->other.dynenv, &s_sstale[10], s_cont);
-  dowinds(cont->other.dynenv,
-	  ilength(dynwinds)-ilength(cont->other.dynenv));
+    wta(tocont, &s_sstale[10], s_cont);
+  dowinds(cont->other.dynenv);
   {
-    SCM *from, *to;
-    sizet n = LENGTH(cont->other.env);
-    if (LENGTH(scm_estk) < n)
-      scm_estk_grow((n - (LENGTH(scm_estk))) / SCM_ESTK_FRLEN + 20);
     DEFER_INTS;
-    from =  VELTS(cont->other.env);
-    to = VELTS(scm_estk);
-    scm_env = from[--n];
-    scm_env_tmp = from[--n];
-    scm_estk_ptr = &(to[n]) - SCM_ESTK_FRLEN;
-    while(n--) to[n] = from[n];
+#ifdef CHEAP_CONTINUATIONS
+    scm_estk = cont->other.estk;
+    scm_estk_ptr = cont->other.estk_ptr;
+#else
+    {
+      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));
+      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];
     ALLOW_INTS;
   }
   throw_to_continuation(cont, val, CONT(rootcont));
-  wta(cont->other.dynenv, s_sstale, s_cont);
+  wta(tocont, s_sstale, s_cont);
 }
 
 SCM obhash(obj)
@@ -1523,67 +1688,132 @@ badhplims:
   wta(UNDEFINED, s_nogrow, s_heap);
 }
 
-smobfuns *smobs;
-sizet numsmob;
-long newsmob(smob)
-     smobfuns *smob;
+/* Initialize a Growable arRAy, of initial size LEN, growing to at most
+   MAXLEN elements of size ELTSIZE */
+void scm_init_gra(gra, eltsize, len, maxlen, what)
+     scm_gra *gra;
+     sizet eltsize, len, maxlen;
+     char *what;
+{
+  char *nelts;
+  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;
+  gra->elts = nelts;
+  gra->alloclen = len;
+  gra->maxlen = maxlen;
+  gra->what = what;
+  ALLOW_INTS;
+}
+/* Returns the index into the elt array */
+int scm_grow_gra(gra, elt)
+     scm_gra *gra;
+     char *elt;
 {
+  int i;
   char *tmp;
-  if (255 <= numsmob) goto smoberr;
   DEFER_INTS;
-  SYSCALL(tmp = (char *)realloc((char *)smobs, (1+numsmob)*sizeof(smobfuns)););
-  if (tmp) {
-    smobs = (smobfuns *)tmp;
-    smobs[numsmob].mark = smob->mark;
-    smobs[numsmob].free = smob->free;
-    smobs[numsmob].print = smob->print;
-    smobs[numsmob].equalp = smob->equalp;
-    numsmob++;
+  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);
+    /*
+      SYSCALL(tmp = realloc(gra->elts, nlen*gra->eltsize););
+      if (!tmp) goto growerr;
+      mallocated += (nlen - gra->alloclen)*gra->eltsize;
+    */
+    tmp = must_realloc(gra->elts, (long)gra->alloclen*gra->eltsize,
+		       (long)nlen*gra->eltsize, gra->what);
+    gra->elts = tmp;
+    gra->alloclen = nlen;
   }
+  tmp = &gra->elts[gra->len*gra->eltsize];
+  gra->len += 1;
+  for (i = 0; i < gra->eltsize; i++)
+    tmp[i] = elt[i];
   ALLOW_INTS;
-  if (!tmp) smoberr: wta(MAKINUM((long)numsmob), (char *)NALLOC, "newsmob");
-  return tc7_smob + (numsmob-1)*256;
+  return gra->len - 1;
+}
+void scm_free_gra(gra)
+     scm_gra *gra;
+{
+  free(gra->elts);
+  gra->elts = 0;
+  mallocated -= gra->maxlen*gra->eltsize;
+}
+scm_gra smobs_gra;
+long newsmob(smob)
+     smobfuns *smob;
+{
+  return tc7_smob + 256*scm_grow_gra(&smobs_gra, (char *)smob);
 }
-ptobfuns *ptobs;
-sizet numptob;
+scm_gra ptobs_gra;
 long newptob(ptob)
      ptobfuns *ptob;
 {
-  char *tmp;
-  if (255 <= numptob) goto ptoberr;
-  DEFER_INTS;
-  SYSCALL(tmp = (char *)realloc((char *)ptobs, (1+numptob)*sizeof(ptobfuns)););
-  if (tmp) {
-    ptobs = (ptobfuns *)tmp;
-    ptobs[numptob].mark = ptob->mark;
-    ptobs[numptob].free = ptob->free;
-    ptobs[numptob].print = ptob->print;
-    ptobs[numptob].equalp = ptob->equalp;
-    ptobs[numptob].fputc = ptob->fputc;
-    ptobs[numptob].fputs = ptob->fputs;
-    ptobs[numptob].fwrite = ptob->fwrite;
-    ptobs[numptob].fflush = ptob->fflush;
-    ptobs[numptob].fgetc = ptob->fgetc;
-    ptobs[numptob].fclose = ptob->fclose;
-    numptob++;
+  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 char s_port_table[] = "port table";
+SCM scm_port_entry(ptype, flags)
+     long ptype, flags;
+{
+  int 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++)
+    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);
   }
-  ALLOW_INTS;
-  if (!tmp) ptoberr: wta(MAKINUM((long)numptob), (char *)NALLOC, "newptob");
-  return tc7_port + (numptob-1)*256;
+  else if (scm_port_table_len < PORT_TABLE_MAXLEN) {
+    nlen = scm_port_table_len + (scm_port_table_len / 2);
+    if (nlen > PORT_TABLE_MAXLEN) nlen = PORT_TABLE_MAXLEN;
+    scm_port_table = (port_info *)
+      must_realloc((char *)scm_port_table,
+		   (long)scm_port_table_len*sizeof(port_info),
+		   nlen*sizeof(port_info)+0L,
+		   s_port_table);
+    scm_port_table_len = nlen;
+    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;
+    }
+  }
+  else {
+    igc(s_port_table, CONT(rootcont)->stkbse);
+    for (i = 0; i < scm_port_table_len; i++)
+      if (0L==scm_port_table[i].flags) goto ret;
+    wta(UNDEFINED, s_nogrow, s_port_table);
+  }
+ ret:
+  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 markcdr(ptr)
      SCM ptr;
 {
-  if GC8MARKP(ptr) return BOOL_F;
-  SETGC8MARK(ptr);
   return CDR(ptr);
 }
-SCM mark0(ptr)
-     SCM ptr;
-{
-  SETGC8MARK(ptr);
-  return BOOL_F;
-}
 sizet free0(ptr)
      CELLPTR ptr;
 {
@@ -1595,31 +1825,30 @@ SCM equal0(ptr1, ptr2)
   return (CDR(ptr1)==CDR(ptr2)) ? BOOL_T : BOOL_F;
 }
 
-/* statically allocated ports for diagnostic messages */
-static cell tmp_errpbuf[3];
-static SCM tmp_errp;
-
-static char remsg[] = "remove\n#define ", addmsg[] = "add\n#define ";
-extern sizet num_protects;	/* sys_protects now in scl.c */
+static char remsg[] = "remove\n#define ", addmsg[] = "add\n#define ",
+  rdmsg[] = "reduce";
 void init_storage(stack_start_ptr, init_heap_size)
      STACKITEM *stack_start_ptr;
      long init_heap_size;
 {
-	sizet j = num_protects;
+	sizet j;
 	/* Because not all protects may get initialized */
-	while(j) sys_protects[--j] = BOOL_F;
-	tmp_errp = PTR2SCM(CELL_UP(&tmp_errpbuf[0]));
-	CAR(tmp_errp) = (SCM)(tc16_fport|OPN|WRTNG);
-	CDR(tmp_errp) = (SCM)stderr;
 	freelist = EOL;
 	expmem = 0;
 
+#ifdef SHORT_SIZET
+	if (sizeof(sizet) >= sizeof(long))
+	  fixconfig(remsg, "SHORT_SIZET", 0);
+#else
+	if (sizeof(sizet) < sizeof(long))
+	  fixconfig(addmsg, "SHORT_SIZET", 0);
+#endif
 #ifdef SHORT_INT
 	if (sizeof(int) >= sizeof(long))
-	  fixconfig(remsg, "SHORT_INT", 1);
+	  fixconfig(remsg, "SHORT_INT", 0);
 #else
 	if (sizeof(int) < sizeof(long))
-	  fixconfig(addmsg, "SHORT_INT", 1);
+	  fixconfig(addmsg, "SHORT_INT", 0);
 #endif
 #ifdef CDR_DOUBLES
 	if (sizeof(double) != sizeof(long))
@@ -1640,6 +1869,8 @@ void init_storage(stack_start_ptr, init_heap_size)
 	if (DIGSPERLONG*sizeof(BIGDIG) > sizeof(long))
 	  fixconfig(addmsg, "DIGSTOOBIG", 0);
 # endif
+	if (NUMDIGS_MAX > (((unsigned long)-1L)>>16))
+	  fixconfig(rdmsg, "NUMDIGS_MAX", 0);
 #endif
 #ifdef STACK_GROWS_UP
 	if (((STACKITEM *)&j - stack_start_ptr) < 0)
@@ -1650,7 +1881,7 @@ void init_storage(stack_start_ptr, init_heap_size)
 #endif
 	j = HEAP_SEG_SIZE;
 	if (HEAP_SEG_SIZE != j)
-	  fixconfig("reduce", "size of HEAP_SEG_SIZE", 0);
+	  fixconfig(rdmsg, "size of HEAP_SEG_SIZE", 0);
 
 	mtrigger = INIT_MALLOC_LIMIT;
 	mltrigger = mtrigger - MIN_MALLOC_YIELD;
@@ -1667,10 +1898,10 @@ void init_storage(stack_start_ptr, init_heap_size)
 		/* hplims[0] can change. do not remove heap_org */
 
 	NEWCELL(def_inp);
-	CAR(def_inp) = (tc16_fport|OPN|RDNG);
+	CAR(def_inp) = scm_port_entry(tc16_fport, OPN|RDNG);
 	SETSTREAM(def_inp, stdin);
 	NEWCELL(def_outp);
-	CAR(def_outp) = (tc16_fport|OPN|WRTNG);
+	CAR(def_outp) = scm_port_entry(tc16_fport, OPN|WRTNG|TRACKED);
 	SETSTREAM(def_outp, stdout);
 	NEWCELL(def_errp);
 	CAR(def_errp) = (tc16_fport|OPN|WRTNG);
@@ -1681,6 +1912,7 @@ void init_storage(stack_start_ptr, init_heap_size)
 	NEWCELL(sys_errp);
 	CAR(sys_errp) = (tc16_sysport|OPN|WRTNG);
 	SETSTREAM(sys_errp, 0);
+	sys_safep = mksafeport(0, def_errp);
 	dynwinds = EOL;
 	NEWCELL(rootcont);
 	SETCONT(rootcont, make_root_continuation(stack_start_ptr));
@@ -1708,14 +1940,8 @@ void init_storage(stack_start_ptr, init_heap_size)
 	scm_ecache_len = CELL_DN(ecache_v + scm_ecache_len - 1) - scm_ecache + 1;
 	scm_ecache_index = scm_ecache_len;
 	scm_egc_root_index = sizeof(scm_egc_roots)/sizeof(SCM);
-	scm_estk_reset();
-
-#ifdef NUM_HP
-	/* Allocate a very small initial num_hp in case 
-	   we need it only for flo0. */
-	num_hp_add(10*sizeof(double));
-	num_hp_head = num_hp_cur;
-#endif /* def NUM_HP */
+	scm_estk = BOOL_F;
+	scm_estk_reset(0);
 }
 
 /* The way of garbage collecting which allows use of the cstack is due to */
@@ -1766,6 +1992,11 @@ SCM gc_for_newcell()
 	return fl;
 }
 
+void gc_for_open_files()
+{
+  igc("open files", CONT(rootcont)->stkbse);
+}
+
 void scm_fill_freelist()
 {
   while IMP(freelist) {
@@ -1783,7 +2014,10 @@ 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 sweep_symhash P((SCM v));
+static void mark_port_table P((SCM port));
+static void sweep_port_table P((void));
 static void egc_mark P((void));
 static void egc_sweep P((void));
 
@@ -1804,12 +2038,14 @@ void igc(what, stackbase)
 {
   int j = num_protects;
   long oheap_cells = heap_cells;
-  gc_start(what);
-  if (++errjmp_bad > 1)
-    wta(MAKINUM(errjmp_bad), s_recursive, s_gc);
-#ifdef NUM_HP
-  num_hp_switch();	/* Switch half-heaps for flonums/bignums */
+#ifdef DEBUG_GMALLOC
+  int err = check_frag_blocks();
+  if (err) wta(MAKINUM(err), "malloc corrupted", what);
 #endif
+  gc_start(what);
+  if (errjmp_bad)
+    wta(UNDEFINED, s_recursive, s_gc);
+  errjmp_bad = s_gc;
 #ifdef NO_SYM_GC
   gc_mark(symhash);
 #else
@@ -1821,6 +2057,7 @@ void igc(what, stackbase)
   /* mark_sym_values() can be called anytime after mark_syms.  */
   mark_sym_values(symhash);
 #endif
+  mark_subr_table();
   egc_mark();
   if (stackbase) {
     FLUSH_REGISTER_WINDOWS;
@@ -1855,15 +2092,10 @@ void igc(what, stackbase)
   sweep_symhash(symhash);
 #endif
   gc_sweep(!stackbase);
+  sweep_port_table();
   egc_sweep();
-#if 0      /* def NUM_HP */
-  if (num_hp_cur) {
-    num_hp *hp = num_hp_cur->next;
-    num_hp_cur->next = 0;
-    if (hp) num_hp_free(hp);
-  }
-#endif  
-  --errjmp_bad;
+  estk_pool = EOL;
+  errjmp_bad = (char *)0;
   gc_end();
   if (oheap_cells != heap_cells) {
     int grewp = heap_cells > oheap_cells;
@@ -1877,8 +2109,8 @@ void free_storage()
 {
   DEFER_INTS;
   gc_start("free");
-  ++errjmp_bad;
-  cur_inp = BOOL_F; cur_outp = BOOL_F; 
+  errjmp_bad = "free_storage";
+  cur_inp = BOOL_F; cur_outp = BOOL_F;
   cur_errp = tmp_errp; sys_errp = tmp_errp;
   gc_mark(def_inp);		/* don't want to close stdin */
   gc_mark(def_outp);		/* don't want to close stdout */
@@ -1899,23 +2131,18 @@ void free_storage()
   if (hplim_ind) wta((SCM)MAKINUM(hplim_ind), s_not_free, s_hplims);
   /* Not all cells get freed (see gc_mark() calls above). */
   /* if (cells_allocated) wta(MAKINUM(cells_allocated), s_not_free, "cells"); */
-#ifdef NUM_HP
-  num_hp_free(num_hp_head);
-#endif
   /* either there is a small memory leak or I am counting wrong. */
   must_free((char *)hplims, 0);
   /* if (mallocated) wta(MAKINUM(mallocated), s_not_free, "malloc"); */
   hplims = 0;
-  /*  must_free((char *)smobs, numsmob * sizeof(smobfuns)); */
-  free((char *)smobs);
-  smobs = 0;
-  gc_end(); 
+  scm_free_gra(&finals_gra);
+  scm_free_gra(&smobs_gra);
+  scm_free_gra(&subr_table_gra);
+  gc_end();
   ALLOW_INTS; /* A really bad idea, but printing does it anyway. */
   exit_report();
   lflush(sys_errp);
-  /* must_free((char *)ptobs, numptob * sizeof(ptobfuns)); */
-  free((char *)ptobs);
-  ptobs = 0;
+  scm_free_gra(&ptobs_gra);
   lmallocated = mallocated = 0;
   /* Can't do gc_end() here because it uses ptobs which have been freed */
   fflush(stdout);		/* in lieu of close */
@@ -2015,6 +2242,7 @@ void gc_mark(p)
   case tc7_bvect:
   case tc7_ivect:
   case tc7_uvect:
+  case tc7_svect:
   case tc7_fvect:
   case tc7_dvect:
   case tc7_cvect:
@@ -2022,59 +2250,36 @@ void gc_mark(p)
   case tcs_subrs:
     break;
   case tc7_port:
+    if GC8MARKP(ptr) break;
+    SETGC8MARK(ptr);
     i = PTOBNUM(ptr);
     if (!(i < numptob)) goto def;
+    mark_port_table(ptr);
+    if (!ptobs[i].mark) break;
     ptr = (ptobs[i].mark)(ptr);
     goto gc_mark_loop;
   case tc7_smob:
     if GC8MARKP(ptr) break;
+    SETGC8MARK(ptr);
     switch TYP16(ptr) {		/* should be faster than going through smobs */
     case tc_free_cell:
       /* printf("found free_cell %X ", ptr); fflush(stdout); */
-      SETGC8MARK(ptr);
       ASSERT(tc_broken_heart!=CAR(ptr), ptr, "found ecache forward", s_gc);
       /*      CDR(ptr) = UNDEFINED */;
       break;
 #ifdef BIGDIG
     case tcs_bignums:
-#ifdef NUM_HP
-      if (NUMDIGS(ptr)*sizeof(BIGDIG) <= NUM_HP_MAX_REQ) {
-	sizet i = NUMDIGS(ptr);
-	BIGDIG *nw = (BIGDIG *)num_hp_alloc(i*sizeof(BIGDIG));
-	while (i--) nw[i] = BDIGITS(ptr)[i];
-      }
-#endif
-      SETGC8MARK(ptr);
       break;
 #endif
 #ifdef FLOATS
     case tc16_flo:
-# ifdef NUM_HP
-      {
-	double *nw;
-	switch ((int)(CAR(ptr)>>16)) {
-	default: goto def;
-	case (IMAG_PART | REAL_PART)>>16:
-	  nw = (double *)num_hp_alloc(2*sizeof(double));
-	  nw[0] = REAL(ptr);
-	  nw[1] = IMAG(ptr);
-	  CDR(ptr) = (SCM)nw;
-	  break;
-	case REAL_PART>>16: case IMAG_PART>>16:
-	  nw = (double *)num_hp_alloc(sizeof(double));
-	  nw[0] = REAL(ptr);
-	  CDR(ptr) = (SCM)nw;
-	  break;
-	case 0: break;
-	}
-      }
-# endif /* def NUM_HP */
-      SETGC8MARK(ptr);
       break;
 #endif
     default:
       i = SMOBNUM(ptr);
       if (!(i < numsmob)) goto def;
+      SETGC8MARK(ptr);
+      if (!smobs[i].mark)  break;
       ptr = (smobs[i].mark)(ptr);
       goto gc_mark_loop;
     }
@@ -2122,8 +2327,9 @@ static void gc_sweep(contin_bad)
 # define scmptr (SCM)ptr
 #endif
   register SCM nfreelist = EOL;
-  register long n = 0, m = 0;
+  register long n = 0;
   register sizet j, minc;
+  long pre_m = mallocated;
   sizet i = 0;
   sizet seg_cells;
   while (i<hplim_ind) {
@@ -2153,7 +2359,6 @@ static void gc_sweep(contin_bad)
 	if GC8MARKP(scmptr) goto c8mrkcontinue;
 	minc = (LENGTH(scmptr)*sizeof(SCM));
       freechars:
-	m += minc;
 	must_free(CHARS(scmptr), minc);
 /*	SETCHARS(scmptr, 0);*/
 	break;
@@ -2166,6 +2371,10 @@ static void gc_sweep(contin_bad)
 	if GC8MARKP(scmptr) goto c8mrkcontinue;
 	minc = HUGE_LENGTH(scmptr)*sizeof(long);
 	goto freechars;
+      case tc7_svect:
+	if GC8MARKP(scmptr) goto c8mrkcontinue;
+	minc = HUGE_LENGTH(scmptr)*sizeof(short);
+	goto freechars;
       case tc7_fvect:
 	if GC8MARKP(scmptr) goto c8mrkcontinue;
 	minc = HUGE_LENGTH(scmptr)*sizeof(float);
@@ -2189,7 +2398,7 @@ static void gc_sweep(contin_bad)
       case tc7_contin:
 	if GC8MARKP(scmptr) {
 	  if (contin_bad && CONT(scmptr)->length) {
-	    warn("uncollected ", (char *)0);
+	    scm_warn("uncollected ", (char *)0);
 	    iprin1(scmptr, cur_errp, 1);
 	    lputc('\n', cur_errp);
 	    lfflush(cur_errp);
@@ -2197,6 +2406,7 @@ static void gc_sweep(contin_bad)
 	  goto c8mrkcontinue;
 	}
 	minc = LENGTH(scmptr)*sizeof(STACKITEM) + sizeof(CONTINUATION);
+	mallocated = mallocated - minc;
 	free_continuation(CONT(scmptr)); break; /* goto freechars; */
       case tc7_ssymbol:
 	if GC8MARKP(scmptr) goto c8mrkcontinue;
@@ -2211,7 +2421,7 @@ static void gc_sweep(contin_bad)
 	  int k = PTOBNUM(scmptr);
 	  if (!(k < numptob)) goto sweeperr;
 				/* Yes, I really do mean ptobs[k].free */
-				/* rather than ftobs[k].close.  .close */
+				/* rather than ptobs[k].close.  .close */
 				/* is for explicit CLOSE-PORT by user */
 	  (ptobs[k].free)(STREAM(scmptr));
 	  gc_ports_collected++;
@@ -2227,16 +2437,12 @@ static void gc_sweep(contin_bad)
 #ifdef BIGDIG
 	case tcs_bignums:
 	  if GC8MARKP(scmptr) goto c8mrkcontinue;
-# ifdef NUM_HP
-	  if (NUMDIGS(scmptr)*sizeof(BIGDIG) <= NUM_HP_MAX_REQ) break;
-# endif /* def NUM_HP */
-	  minc = (NUMDIGS(scmptr)*BITSPERDIG/CHAR_BIT);
+	  minc = (NUMDIGS(scmptr)*sizeof(BIGDIG));
 	  goto freechars;
 #endif /* def BIGDIG */
 #ifdef FLOATS
 	case tc16_flo:
 	  if GC8MARKP(scmptr) goto c8mrkcontinue;
-# ifndef NUM_HP
 	  switch ((int)(CAR(scmptr)>>16)) {
 	  case (IMAG_PART | REAL_PART)>>16:
 	    minc = 2*sizeof(double);
@@ -2250,7 +2456,6 @@ static void gc_sweep(contin_bad)
 	  default:
 	    goto sweeperr;
 	  }
-# endif /* ndef NUM_HP */
 #endif /* def FLOATS */
 	  break;
 	default:
@@ -2296,9 +2501,8 @@ static void gc_sweep(contin_bad)
   }
   lcells_allocated += (heap_cells - gc_cells_collected - cells_allocated);
   cells_allocated = (heap_cells - gc_cells_collected);
-  lmallocated -= m;
-  mallocated -= m;
-  gc_malloc_collected = m;
+  gc_malloc_collected = (pre_m - mallocated);
+  lmallocated = lmallocated - gc_malloc_collected;
 }
 
 #ifndef NO_SYM_GC
@@ -2376,6 +2580,37 @@ static void sweep_symhash(v)
 }
 #endif
 
+static void mark_subr_table()
+{
+  subr_info *table = subr_table;
+  int k = subr_table_gra.len;
+  /* while (k--) { } */
+}
+static void mark_port_table(port)
+     SCM port;
+{
+  int i = SCM_PORTNUM(port);
+  ASSERT(i>=0 && i<scm_port_table_len, MAKINUM(i), "bad port", s_gc);
+  if (i) {
+    scm_port_table[i].flags |= 1;
+    if (NIMP(scm_port_table[i].data))
+      gc_mark(scm_port_table[i].data);
+  }
+}
+static void sweep_port_table()
+{
+  int k;
+	/* tmp_errp gets entry 0, so we never clear its flags. */
+  for(k = scm_port_table_len - 1; k > 0; k--) {
+    if (scm_port_table[k].flags & 1)
+      scm_port_table[k].flags &= (~1L);
+    else {
+      scm_port_table[k].flags = 0L;
+      scm_port_table[k].data = EOL;
+    }
+  }
+}
+
 /* Environment cache GC routines */
 /* This is called during a non-cache gc. We only mark those stack frames
    that are in use. */
@@ -2386,7 +2621,7 @@ static void egc_mark()
   gc_mark(scm_env);
   gc_mark(scm_env_tmp);
   if IMP(scm_estk) return;	/* Can happen when moving estk. */
-  if GC8MARKP(scm_estk) return;	
+  if GC8MARKP(scm_estk) return;
   v = VELTS(scm_estk);
   SETGC8MARK(scm_estk);
   i = scm_estk_ptr - v + SCM_ESTK_FRLEN;
@@ -2407,6 +2642,13 @@ static void egc_sweep()
       CLRGC8MARK(z);
     }
   }
+  /* Under some circumstances I don't fully understand, continuations may
+     point to dead ecache cells. This prevents gc marked cells from causing
+     errors during ecache gc. */
+  for (i = scm_ecache_index; i--;) {
+    scm_ecache[i].car = UNSPECIFIED;
+    scm_ecache[i].cdr = UNSPECIFIED;
+  }
 }
 
 #define ECACHEP(x) (PTR_LE((CELLPTR)(ecache_v), (CELLPTR)SCM2PTR(x)) && \
@@ -2437,7 +2679,7 @@ static void egc_copy(px)
   } while (NIMP(x) && ECACHEP(x));
 }
 
-static void egc_copy_stack(ve, len)
+static void egc_copy_locations(ve, len)
      SCM *ve;
      sizet len;
 {
@@ -2451,7 +2693,18 @@ static void egc_copy_stack(ve, len)
 	egc_copy(&(ve[len]));
   }
 }
-
+static void egc_copy_stack(stk, len)
+     SCM stk;
+     sizet len;
+{
+  while (!0) {
+    egc_copy_locations(VELTS(stk), len);
+    len = INUM(SCM_ESTK_PARENT_INDEX(stk)) + SCM_ESTK_FRLEN;
+    stk =SCM_ESTK_PARENT(stk);
+    if IMP(stk) return;
+    /*    len = LENGTH(stk); */
+  }
+}
 extern long tc16_env, tc16_promise;
 static void egc_copy_roots()
 {
@@ -2476,17 +2729,20 @@ static void egc_copy_roots()
     case tc3_cons_nimcar:	/* These are environment frames that have
 				   been destructively altered by DEFINE or
 				   LETREC.  This is only a problem if a
-				   non-cache cell was made to point into the 
+				   non-cache cell was made to point into the
 				   cache. */
       if ECACHEP(x) break;
       e = CDR(x);
-      if (NIMP(e) && ECACHEP(e)) 
+      if (NIMP(e) && ECACHEP(e))
 	egc_copy(&(CDR(x)));
       break;
     default:
       if (tc7_contin==TYP7(x)) {
-	x = CONT(x)->other.env;
-	egc_copy_stack(VELTS(x), (sizet)LENGTH(x));
+	egc_copy_locations(CONT(x)->other.stkframe, 2);
+#ifndef CHEAP_CONTINUATIONS
+	x = CONT(x)->other.estk;
+	egc_copy_stack(x, LENGTH(x));
+#endif
 	break;
       }
       if (tc16_env==CAR(x)) {
@@ -2504,12 +2760,26 @@ static void egc_copy_roots()
   scm_egc_root_index = sizeof(scm_egc_roots)/sizeof(SCM);
 }
 extern long scm_stk_moved, scm_clo_moved, scm_env_work;
+static int egc_need_gc()
+{
+  SCM fl = freelist;
+  int n;
+  if (heap_cells - cells_allocated <= scm_ecache_len)
+    return 1;
+ /* Interrupting a NEWCELL could leave cells_allocated inconsistent with
+    freelist, see handle_it() in repl.c */
+  for (n = 4; n; n--) {
+    if IMP(fl) return 1;
+    fl = CDR(fl);
+  }
+  return 0;
+}
 void scm_egc()
 {
-  VERIFY_INTS("scm_egc", 0);
+  VERIFY_INTS("scm_egc", 0L);
 /* We need to make sure there are enough cells available to migrate
    the entire environment cache, gc does not work properly during ecache gc */
-  while ((heap_cells - cells_allocated <= scm_ecache_len) || IMP(freelist)) {
+  while (egc_need_gc()) {
     igc("ecache", CONT(rootcont)->stkbse);
     if ((gc_cells_collected < MIN_GC_YIELD) ||
 	(heap_cells - cells_allocated <= scm_ecache_len) || IMP(freelist)) {
@@ -2518,8 +2788,8 @@ void scm_egc()
       growth_mon(s_heap, heap_cells, s_cells, !0);
     }
   }
-  if (++errjmp_bad > 1)
-    wta(MAKINUM(errjmp_bad), s_recursive, s_cache_gc);
+  if (errjmp_bad)
+    wta(UNDEFINED, s_recursive, s_cache_gc);
   {
     SCM stkframe[2];
     long lcells = cells_allocated;
@@ -2531,8 +2801,8 @@ void scm_egc()
     egc_copy_roots();
     scm_clo_moved += cells_allocated - lcells;
     lcells = cells_allocated;
-    egc_copy_stack(stkframe, sizeof(stkframe)/sizeof(SCM));
-    egc_copy_stack(VELTS(scm_estk), nstk);
+    egc_copy_locations(stkframe, sizeof(stkframe)/sizeof(SCM));
+    egc_copy_stack(scm_estk, nstk);
     scm_env = stkframe[0];
     scm_env_tmp = stkframe[1];
     scm_stk_moved += cells_allocated - lcells;
@@ -2540,6 +2810,5 @@ void scm_egc()
     scm_env_work += scm_ecache_len;
     scm_egc_end();
   }
-  --errjmp_bad;
+  errjmp_bad = (char *)0;
 }
-