Import Debian changes 5c3-5debian/5c3-5

scm (5c3-5) frozen unstable; urgency=low

  * debian/rules chmod +x's bld.scm. Fixes #30521.

scm (5c3-4) frozen unstable; urgency=low

  * Made bld.scm executable.  Fixes #29578.

scm (5c3-3) frozen unstable; urgency=low

  * -nw
  * Fixes #16762. 
  * Fixes #18163.
  * Fixes #18164.
  * Fixes #23743.
  * Fixes #24098.
  * Fixes #24099.
  * Fixes #24547.

scm (5c3-2) frozen unstable; urgency=low

  * Re-uploading for slink freeze.

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

  * New upstream version.

1 files changed, 929 insertions, 166 deletions

diff --git a/sys.c b/sys.c
index 9767fe0..82ea647 100644
--- a/sys.c
+++ b/sys.c
@@ -46,6 +46,8 @@
 #include "scm.h"
 #include "setjump.h"
 void	igc P((char *what, STACKITEM *stackbase));
+void	lfflush P((SCM port));		/* internal SCM call */
+SCM	*loc_open_file;		/* for open-file callback */
 
 /* ttyname() etc. should be defined in <unistd.h>.  But unistd.h is
    missing on many systems. */
@@ -66,15 +68,21 @@ void	igc P((char *what, STACKITEM *stackbase));
 	int pclose P((FILE* stream));
 	int unlink P((const char *pathname));
 	char *mktemp P((char *template));
+#else
+# ifdef linux
+#  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";
+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_open_file[] = "open-file";
+static char	s_try_open_file[] = "try-open-file";
+#define	s_open_file (&s_try_open_file[4])
 char	s_close_port[] = "close-port";
 
 #ifdef __IBMC__
@@ -92,7 +100,7 @@ char	s_close_port[] = "close-port";
 #     ifdef MWC
 #      include <sys/io.h>
 #     else
-#      ifndef THINK_C
+#      ifndef macintosh
 #       ifndef ARM_ULIB
 #        include <sys/ioctl.h>
 #       endif
@@ -126,7 +134,7 @@ long mode_bits(modes)
       | (strchr(modes, '0') ? BUF0 : 0);
 }
 
-SCM open_file(filename, modes)
+SCM try_open_file(filename, modes)
      SCM filename, modes;
 {
   register SCM port;
@@ -146,6 +154,15 @@ SCM open_file(filename, modes)
   return port;
 }
 
+				/* Callback to Scheme */
+SCM open_file(filename, modes)
+     SCM filename, modes;
+{
+  return apply(*loc_open_file,
+	       filename,
+	       cons(modes, listofnull));
+}
+
 SCM close_port(port)
      SCM port;
 {
@@ -270,7 +287,7 @@ void prinport(exp, port, type)
 # ifndef __EMX__
 #  ifndef _DCC
 #   ifndef AMIGA
-#    ifndef THINK_C
+#    ifndef macintosh
   if (OPENP(exp) && tc16_fport==TYP16(exp) && isatty(fileno(STREAM(exp))))
     lputs(ttyname(fileno(STREAM(exp))), port);
   else
@@ -280,7 +297,7 @@ void prinport(exp, port, type)
 # endif
 #endif
     if OPFPORTP(exp) intprint((long)fileno(STREAM(exp)), 10, port);
-    else intprint(CDR(exp), 16, port);
+    else intprint(CDR(exp), -16, port);
   lputc('>', port);
 }
 static int prinfport(exp, port, writing)
@@ -337,7 +354,7 @@ static int stgetc(p)
   sizet ind = INUM(CAR(p));
   if (ind >= LENGTH(CDR(p))) return EOF;
   CAR(p) = MAKINUM(ind + 1);
-  return CHARS(CDR(p))[ind];
+  return UCHARS(CDR(p))[ind];
 }
 int noop0(stream)
      FILE *stream;
@@ -400,8 +417,13 @@ static ptobfuns fptob = {
   prinfport,
   0,
   fputc,
+#ifdef __MWERKS__
+  (int (*)(char *, struct _FILE *))fputs,
+  (unsigned long (*)(char *, unsigned long, unsigned long, struct _FILE *))ffwrite,
+#else
   fputs,
   ffwrite,
+#endif
   fflush,
   fgetc,
   fclose};
@@ -411,8 +433,13 @@ ptobfuns pipob = {
   0, 				/* replaced by prinpipe in init_ioext() */
   0,
   fputc,
+#ifdef __MWERKS__
+  (int (*)(char *, struct _FILE *))fputs,
+  (unsigned long (*)(char *, unsigned long, unsigned long, struct _FILE *))ffwrite,
+#else
   fputs,
   ffwrite,
+#endif
   fflush,
   fgetc,
   0};				/* replaced by pclose in init_ioext() */
@@ -513,10 +540,105 @@ static ptobfuns sfptob = {
   sfgetc,
   sfclose};
 
+/* 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
+   written to cur_errp as soon as interrupts are enabled. There will only
+   ever be one of these. */
+int output_deferred = 0;
+static int tc16_sysport;
+#define SYS_ERRP_SIZE 480
+static char errbuf[SYS_ERRP_SIZE];
+static sizet errbuf_end = 0;
+static sizet syswrite(str, siz, num, p)
+     sizet siz, num;
+     char *str; FILE *p;
+{
+  sizet src, dst = errbuf_end;
+  sizet n = siz*num;
+  if (ints_disabled) {
+    deferred_proc = process_signals;
+    output_deferred = !0;
+    for (src = 0; src < n; src++, dst++)
+      errbuf[dst % SYS_ERRP_SIZE] = str[src];
+    errbuf_end = dst;
+  }
+  else {
+    if NIMP(cur_outp) lflush(cur_outp);
+    if (errbuf_end > 0) {
+      if (errbuf_end > SYS_ERRP_SIZE) {
+	warn("output buffer", " overflowed");
+	intprint((long)errbuf_end, 10, cur_errp);
+	lputs(" chars needed\n", cur_errp);
+	errbuf_end = errbuf_end % SYS_ERRP_SIZE;
+	lfwrite(&errbuf[errbuf_end], 1,
+		SYS_ERRP_SIZE - errbuf_end, cur_errp);
+      }
+      lfwrite(errbuf, sizeof(char), errbuf_end, cur_errp);
+      errbuf_end = 0;
+    }
+    num = lfwrite(str, siz, num, cur_errp);
+    lflush(cur_errp);
+  }
+  errno = 0;
+  return num;
+}
+static int sysputs(s, p)
+     char *s; FILE *p;
+{
+  syswrite(s, 1, strlen(s), p);
+  return 0;
+}
+static int sysputc(c, p)
+     int c; FILE *p;
+{
+  char cc = c;
+  syswrite(&cc, 1, 1, p);
+  return c;
+}
+static int sysflush(p)
+     FILE *p;
+{
+  syswrite(0, 0, 0, p);
+  return 0;
+}
+static ptobfuns sysptob = {
+  mark0,
+  noop0,
+  0,
+  0,
+  sysputc,
+  sysputs,
+  syswrite,
+  sysflush,
+  noop0,
+  noop0};
+
+static int freeprint(exp, port, writing)
+     SCM exp; SCM port; int writing;
+{
+  if (tc_broken_heart==CAR(exp)) {
+    lputs("#<GC-FORWARD->", port);
+    iprin1(CDR(exp), port, writing);
+  }
+  else {
+    if (NIMP(CDR(exp)) && tc7_smob==CAR(CDR(exp))) {
+      lputs("#<FREE-CELL ", port);
+    }
+    else {
+      lputs("#<NEW-CELL . ", port);
+      iprin1(CDR(exp), port, writing);
+    }
+    lputs(" @0x", port);
+    intprint((long)exp, -16, port);
+  }
+  lputc('>', port);
+  return !0;
+}
 static smobfuns freecell = {
   mark0,
   free0,
-  0,
+  freeprint,
   0};
 static smobfuns flob = {
   mark0,
@@ -541,6 +663,7 @@ void init_types()
   /* tc16_pipe = */ newptob(&pipob);
   /* tc16_strport = */ newptob(&stptob);
   /* tc16_sfport = */ newptob(&sfptob);
+  tc16_sysport = newptob(&sysptob);
   numsmob = 0;
   smobs = (smobfuns *)malloc(7*sizeof(smobfuns));
   /* These newsmob calls must be done in this order */
@@ -557,7 +680,7 @@ void add_final(final)
 {
   DEFER_INTS;
   finals = (void (**)()) must_realloc((char *)finals,
-				      1L*(num_finals)*sizeof(finals[0]),
+				      (long)(num_finals)*sizeof(finals[0]),
 				      (1L+num_finals)*sizeof(finals[0]),
 				      s_final);
   finals[num_finals++] = final;
@@ -565,9 +688,141 @@ void add_final(final)
   return;
 }
 
-char s_obunhash[] = "object-unhash", s_gc[] = "gc";
+static char s_estk[] = "environment stack";
+static cell ecache_v[ECACHE_SIZE];
+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()
+{
+  SCM nstk = scm_estk, *v;
+  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);
+  }
+  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);
+}
+
+/* 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
+}
+
+void scm_env_cons(x, y)
+     SCM x, y;
+{
+   register SCM z;
+   DEFER_INTS_EGC;
+   if (1>scm_ecache_index) scm_egc();
+   z = PTR2SCM(&(scm_ecache[--scm_ecache_index]));
+   CAR(z) = x;
+   CDR(z) = y;
+   scm_env_tmp = z;
+}
+
+void scm_env_cons2(w, x, y)
+     SCM w, x, y;
+{
+   SCM z1, z2;
+   DEFER_INTS_EGC;
+   if (2>scm_ecache_index) scm_egc();
+   z1 = PTR2SCM(&(scm_ecache[--scm_ecache_index]));
+   CAR(z1) = x;
+   CDR(z1) = y;
+   z2 = PTR2SCM(&(scm_ecache[--scm_ecache_index]));
+   CAR(z2) = w;
+   CDR(z2) = z1;
+   scm_env_tmp = z2; 
+}
+
+/* scm_env_tmp = cons(x, scm_env_tmp) */
+void scm_env_cons_tmp(x)
+     SCM x;
+{
+   register SCM z;
+   DEFER_INTS_EGC;
+   if (1>scm_ecache_index) scm_egc();
+   z = PTR2SCM(&(scm_ecache[--scm_ecache_index]));
+   CAR(z) = x;
+   CDR(z) = scm_env_tmp;
+   scm_env_tmp = z;
+}
+
+/* scm_env = acons(names, scm_env_tmp, scm_env) */
+void scm_extend_env(names)
+     SCM names;
+{
+   SCM z1, z2;
+   DEFER_INTS_EGC;
+   if (2>scm_ecache_index) scm_egc();
+   z1 = PTR2SCM(&(scm_ecache[--scm_ecache_index]));
+   CAR(z1) = names;
+   CDR(z1) = scm_env_tmp;
+   z2 = PTR2SCM(&(scm_ecache[--scm_ecache_index]));
+   CAR(z2) = z1;
+   CDR(z2) = scm_env;
+   scm_env = z2;
+}
+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},
+  /*	{s_gc, gc}, */
 	{"tmpnam", ltmpnam},
 	{0, 0}};
 
@@ -583,17 +838,22 @@ static iproc subr1s[] = {
 	{0, 0}};
 
 static iproc subr2s[] = {
-	{s_open_file, open_file},
+	{s_try_open_file, try_open_file},
 	{s_cwis, cwis},
 	{s_mksfpt, mksfpt},
 	{0, 0}};
 
 SCM dynwind P((SCM thunk1, SCM thunk2, SCM thunk3));
-void init_io(){
+void init_io()
+{
   make_subr("dynamic-wind", tc7_subr_3, dynwind);
+  make_subr(s_gc, tc7_subr_1o, gc);
   init_iprocs(subr0s, tc7_subr_0);
   init_iprocs(subr1s, tc7_subr_1);
   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))));
 #ifndef CHEAP_CONTINUATIONS
   add_feature("full-continuation");
 #endif
@@ -602,75 +862,245 @@ void init_io(){
 void grew_lim(nm)
      long nm;
 {
-  ALLOW_INTS;
-  growth_mon(s_limit, nm, "bytes");
-  DEFER_INTS;
+  growth_mon(s_limit, nm, "bytes", !0);
 }
 int expmem = 0;
 sizet hplim_ind = 0;
-long heap_size = 0;
+long heap_cells = 0;
 CELLPTR *hplims, heap_org;
-SCM freelist = EOL;
-long mtrigger;
+VOLATILE SCM freelist = EOL;
+long mtrigger, mltrigger;
+
+/* Ints should be deferred when calling igc_for_malloc. */
+static char *igc_for_alloc(where, olen, size, what)
+     char *where;
+     long olen;
+     sizet size;
+     char *what;
+{
+  char *ptr;
+  long nm;
+  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););
+  ASSERT(ptr, MAKINUM(size), NALLOC, what);
+  if (nm > mltrigger) {
+    if (nm > mtrigger) mtrigger = nm + nm/2;
+    else mtrigger += mtrigger/2;
+    mltrigger = mtrigger - MIN_MALLOC_YIELD;
+  }
+  return ptr;
+}
 char *must_malloc(len, what)
      long len;
      char *what;
 {
-	char *ptr;
-	sizet size = len;
-	long nm = mallocated+size;
-	if (len != size)
-malerr:
-		wta(MAKINUM(len), (char *)NALLOC, what);
-	if ((nm <= mtrigger)) {
-	  SYSCALL(ptr = (char *)malloc(size););
-	  if (NULL != ptr) {mallocated = nm; return ptr;}
-	}
-	igc(what, CONT(rootcont)->stkbse);
-	nm = mallocated+size;
-	if (nm > mtrigger) grew_lim(nm+nm/2); /* must do before malloc */
-	SYSCALL(ptr = (char *)malloc(size););
-	if (NULL != ptr) {
-	  mallocated = nm;
-	  if (nm > mtrigger) mtrigger = nm + nm/2;
-	  return ptr;}
-	goto malerr;
+  char *ptr;
+  sizet size = len;
+  long nm = mallocated + size;
+  VERIFY_INTS("must_malloc", what);
+  ASSERT(len==size, MAKINUM(len), NALLOC, what);
+  if (nm <= mtrigger)
+    SYSCALL(ptr = (char *)malloc(size););
+  else
+    ptr = 0;
+  if (!ptr) ptr = igc_for_alloc(0, 0, size, what);
+  mallocated = nm;
+  return ptr;
+}
+SCM must_malloc_cell(len, what)
+     long len;
+     char *what;
+{
+  SCM z;
+  char *ptr;
+  sizet size = len;
+  long nm = mallocated + size;
+  VERIFY_INTS("must_malloc_cell", what);
+  ASSERT(len==size, MAKINUM(len), NALLOC, what);
+  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;
+  SETCHARS(z, ptr);
+  return z;
 }
 char *must_realloc(where, olen, len, what)
      char *where;
      long olen, len;
      char *what;
 {
-	char *ptr;
-	sizet size = len;
-	long nm = mallocated+size-olen;
-	if (len != size)
-ralerr:
-		wta(MAKINUM(len), (char *)NALLOC, what);
-	if ((nm <= mtrigger)) {
-	  SYSCALL(ptr = (char *)realloc(where, size););
-	  if (NULL != ptr) {mallocated = nm; return ptr;}
-	}
-	igc(what, CONT(rootcont)->stkbse);
-	nm = mallocated+size-olen;
-	if (nm > mtrigger) grew_lim(nm+nm/2); /* must do before realloc */
-	SYSCALL(ptr = (char *)realloc(where, size););
-	if (NULL != ptr) {
-	  mallocated = nm;
-	  if (nm > mtrigger) mtrigger = nm + nm/2;
-	  return ptr;}
-	goto ralerr;
-}
-void must_free(obj)
+  char *ptr;
+  sizet size = len;
+  long nm = mallocated + size - olen;
+  VERIFY_INTS("must_realloc", what);
+  ASSERT(len==size, MAKINUM(len), NALLOC, what);
+  if (nm <= mtrigger)
+    SYSCALL(ptr = (char *)realloc(where, size););
+  else
+    ptr = 0;
+  if (!ptr) ptr = igc_for_alloc(where, olen, size, what);
+  mallocated = nm;
+  return ptr;
+}
+void must_realloc_cell(z, olen, len, what)
+     SCM z;
+     long olen, len;
+     char *what;
+{
+  char *ptr, *where = CHARS(z);
+  sizet size = len;
+  long nm = mallocated + size - olen;
+  VERIFY_INTS("must_realloc_cell", what);
+  ASSERT(len==size, MAKINUM(len), NALLOC, what);
+  if (nm <= mtrigger)
+    SYSCALL(ptr = (char *)realloc(where, size););
+  else
+    ptr = 0;
+  if (!ptr) ptr = igc_for_alloc(where, olen, size, what);
+  mallocated = nm;
+  SETCHARS(z, ptr);
+}
+void must_free(obj, len)
      char *obj;
+     sizet len;
 {
-  if (obj) free(obj);
+  if (obj) {
+#ifdef CAREFUL_INTS
+    while (len--) obj[len] = '#';
+#endif
+    free(obj);
+  }
   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 unuesd, UNDEFINED
+				   added GC for unused, UNDEFINED
 				   symbols.*/
 int symhash_dim = NUM_HASH_BUCKETS;
 /* sym2vcell looks up the symbol in the symhash table. */
@@ -718,7 +1148,7 @@ SCM intern(name, len)
   return z;
 }
 SCM sysintern(name, val)
-     char *name;
+     const char *name;
      SCM val;
 {
   SCM lsym, z;
@@ -738,8 +1168,10 @@ SCM sysintern(name, val)
   trynext: ;
   }
   NEWCELL(lsym);
+  DEFER_INTS;
   SETLENGTH(lsym, (long)len, tc7_ssymbol);
   SETCHARS(lsym, name);
+  ALLOW_INTS;
   lsym = cons(lsym, val);
   z = cons(lsym, UNDEFINED);
   CDR(z) = VELTS(symhash)[hash];
@@ -786,17 +1218,16 @@ SCM makstr(len)
      long len;
 {
 	SCM s;
-	NEWCELL(s);
 	DEFER_INTS;
-	SETCHARS(s, must_malloc(len+1, s_string));
+	s = must_malloc_cell(len+1, s_string);
 	SETLENGTH(s, len, tc7_string);
-	ALLOW_INTS;
 	CHARS(s)[len] = 0;
+   	ALLOW_INTS;
 	return s;
 }
 
 SCM make_subr(name, type, fcn)
-     char *name;
+     const char *name;
      int type;
      SCM (*fcn)();
 {
@@ -806,8 +1237,8 @@ SCM make_subr(name, type, fcn)
 	if ((tmp>>8) != ((CELLPTR)(CAR(symcell))-heap_org))
 	  tmp = 0;
 	NEWCELL(z);
-	SUBRF(z) = fcn;
 	CAR(z) = tmp + type;
+	SUBRF(z) = fcn;
 	CDR(symcell) = z;
 	return z;
 }
@@ -818,10 +1249,9 @@ SCM makcclo(proc, len)
      long len;
 {
   SCM s;
-  NEWCELL(s);
   DEFER_INTS;
-  SETCHARS(s, must_malloc(len*sizeof(SCM), "compiled-closure"));
-  SETLENGTH(s, len, tc7_cclo);
+  s = must_malloc_cell(len*sizeof(SCM), "compiled-closure");
+  SETNUMDIGS(s, len, tc16_cclo);
   while (--len) VELTS(s)[len] = UNSPECIFIED;
   CCLO_SUBR(s) = proc;
   ALLOW_INTS;
@@ -839,18 +1269,22 @@ void stack_check()
 # else
   if (start - &stack > STACK_LIMIT/sizeof(STACKITEM))
 # endif /* def STACK_GROWS_UP */
-    wta(UNDEFINED, (char *)SEGV_SIGNAL, "stack");
+    {
+      stack_report();
+      wta(UNDEFINED, (char *)SEGV_SIGNAL, "stack");
+    }
 }
 #endif
 void stack_report()
 {
   STACKITEM stack;
-  intprint(stack_size(CONT(rootcont)->stkbse)*sizeof(STACKITEM), 16, cur_errp);
-  lputs(" of stack: 0x", cur_errp);
-  intprint((long)CONT(rootcont)->stkbse, 16, cur_errp);
+  lputs(";; stack: 0x", cur_errp);
+  intprint((long)CONT(rootcont)->stkbse, -16, cur_errp);
   lputs(" - 0x", cur_errp);
-  intprint((long)&stack, 16, cur_errp);
-  lputs("\n", cur_errp);
+  intprint((long)&stack, -16, cur_errp);
+  lputs("; ", cur_errp);
+  intprint(stack_size(CONT(rootcont)->stkbse)*sizeof(STACKITEM), 10, cur_errp);
+  lputs(" bytes\n", cur_errp);
 }
 
 SCM dynwind(thunk1, thunk2, thunk3)
@@ -887,20 +1321,26 @@ void dowinds(to, delta)
 
 SCM scm_make_cont()
 {
-  SCM cont;
+  SCM cont, env, *from, *to;
   CONTINUATION *ncont;
+  sizet n;
+  VERIFY_INTS("scm_make_cont", 0);
   NEWCELL(cont);
-  DEFER_INTS;
+  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];
   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;
-#ifdef CAUTIOUS
-  CONT(cont)->other.stack_trace = stacktrace;
-#endif
-  ALLOW_INTS;
+  ncont->other.env = env;
   return cont;
 }
 static char s_sstale[] = "strangely stale";
@@ -912,9 +1352,20 @@ void scm_dynthrow(cont, val)
     wta(cont->other.dynenv, &s_sstale[10], s_cont);
   dowinds(cont->other.dynenv,
 	  ilength(dynwinds)-ilength(cont->other.dynenv));
-#ifdef CAUTIOUS
-  stacktrace = cont->other.stack_trace;
-#endif
+  {
+    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];
+    ALLOW_INTS;
+  }
   throw_to_continuation(cont, val, CONT(rootcont));
   wta(cont->other.dynenv, s_sstale, s_cont);
 }
@@ -1035,7 +1486,7 @@ sizet init_heap_seg(seg_org, size)
 /*  CDR(scmptr) = freelist; */
   CDR(PTR2SCM(--ptr)) = freelist;
   freelist = PTR2SCM(CELL_UP(seg_org));
-  heap_size += ni;
+  heap_cells += ni;
   return size;
 #ifdef scmptr
 # undef scmptr
@@ -1047,15 +1498,18 @@ static void alloc_some_heap()
   sizet len = (2+hplim_ind)*sizeof(CELLPTR);
   ASRTGO(len==(2+hplim_ind)*sizeof(CELLPTR), badhplims);
   if (errjmp_bad) wta(UNDEFINED, "need larger initial", s_heap);
-  SYSCALL(tmplims = (CELLPTR *)realloc((char *)hplims, len););
+  tmplims = (CELLPTR *)must_realloc((char *)hplims,
+				    len-2L*sizeof(CELLPTR), (long)len,
+				    s_heap);
+  /*  SYSCALL(tmplims = (CELLPTR *)realloc((char *)hplims, len);); */
   if (!tmplims)
 badhplims:
     wta(UNDEFINED, s_nogrow, s_hplims);
   else hplims = tmplims;
   /* hplim_ind gets incremented in init_heap_seg() */
   if (expmem) {
-    len = (sizet)(EXPHEAP(heap_size)*sizeof(cell));
-    if ((sizet)(EXPHEAP(heap_size)*sizeof(cell)) != len) len = 0;
+    len = (sizet)(EXPHEAP(heap_cells)*sizeof(cell));
+    if ((sizet)(EXPHEAP(heap_cells)*sizeof(cell)) != len) len = 0;
   }
   else len = HEAP_SEG_SIZE;
   while (len >= MIN_HEAP_SEG_SIZE) {
@@ -1141,8 +1595,9 @@ SCM equal0(ptr1, ptr2)
   return (CDR(ptr1)==CDR(ptr2)) ? BOOL_T : BOOL_F;
 }
 
-/* statically allocated port for diagnostic messages */
-cell tmp_errp = {(SCM)((0L<<8)|tc16_fport|OPN|WRTNG), 0};
+/* 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 */
@@ -1153,8 +1608,9 @@ void init_storage(stack_start_ptr, init_heap_size)
 	sizet j = num_protects;
 	/* Because not all protects may get initialized */
 	while(j) sys_protects[--j] = BOOL_F;
-	tmp_errp.cdr = (SCM)stderr;
-	cur_errp = PTR2SCM(&tmp_errp);
+	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;
 
@@ -1197,6 +1653,7 @@ void init_storage(stack_start_ptr, init_heap_size)
 	  fixconfig("reduce", "size of HEAP_SEG_SIZE", 0);
 
 	mtrigger = INIT_MALLOC_LIMIT;
+	mltrigger = mtrigger - MIN_MALLOC_YIELD;
 	hplims = (CELLPTR *) must_malloc(2L*sizeof(CELLPTR), s_hplims);
 	if (0L==init_heap_size) init_heap_size = INIT_HEAP_SIZE;
 	j = init_heap_size;
@@ -1221,16 +1678,15 @@ void init_storage(stack_start_ptr, init_heap_size)
 	cur_inp = def_inp;
 	cur_outp = def_outp;
 	cur_errp = def_errp;
+	NEWCELL(sys_errp);
+	CAR(sys_errp) = (tc16_sysport|OPN|WRTNG);
+	SETSTREAM(sys_errp, 0);
 	dynwinds = EOL;
 	NEWCELL(rootcont);
 	SETCONT(rootcont, make_root_continuation(stack_start_ptr));
 	CAR(rootcont) = tc7_contin;
 	CONT(rootcont)->other.dynenv = EOL;
 	CONT(rootcont)->other.parent = BOOL_F;
-	stacktrace = EOL;
-#ifdef CAUTIOUS
-	CONT(rootcont)->other.stack_trace = EOL;
-#endif
 	listofnull = cons(EOL, EOL);
 	undefineds = cons(UNDEFINED, EOL);
 	CDR(undefineds) = undefineds;
@@ -1246,6 +1702,20 @@ void init_storage(stack_start_ptr, init_heap_size)
 	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);
+	scm_ecache = CELL_UP(ecache_v);
+	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 */
 }
 
 /* The way of garbage collecting which allows use of the cstack is due to */
@@ -1281,33 +1751,50 @@ char s_cells[] = "cells";
 SCM gc_for_newcell()
 {
 	SCM fl;
-	DEFER_INTS;
+	int oints = ints_disabled; /* Temporary expedient */
+	if (!oints) ints_disabled = 1;
 	igc(s_cells, CONT(rootcont)->stkbse);
-	ALLOW_INTS;
 	if ((gc_cells_collected < MIN_GC_YIELD) || IMP(freelist)) {
-	  DEFER_INTS;
 	  alloc_some_heap();
-	  ALLOW_INTS;
-	  growth_mon("number of heaps", (long)(hplim_ind/2), "segments");
-	  growth_mon(s_heap, heap_size, s_cells);
+	  growth_mon(s_numheaps, (long)(hplim_ind/2), s_segs, !0);
+	  growth_mon(s_heap, heap_cells, s_cells, !0);
 	}
 	++cells_allocated;
 	fl = freelist;
 	freelist = CDR(fl);
+	ints_disabled = oints;
 	return fl;
 }
 
+void scm_fill_freelist()
+{
+  while IMP(freelist) {
+    igc(s_cells, CONT(rootcont)->stkbse);
+    if ((gc_cells_collected < MIN_GC_YIELD) || IMP(freelist)) {
+      alloc_some_heap();
+      growth_mon(s_numheaps, (long)(hplim_ind/2), s_segs, !0);
+      growth_mon(s_heap, heap_cells, s_cells, !0);
+    }
+  }
+}
+
 static char	s_bad_type[] = "unknown type in ";
 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 sweep_symhash P((SCM v));
+static void egc_mark P((void));
+static void egc_sweep P((void));
 
-SCM gc()
+SCM gc(arg)
+     SCM arg;
 {
   DEFER_INTS;
-  igc("call", CONT(rootcont)->stkbse);
+  if UNBNDP(arg)
+    igc("call", CONT(rootcont)->stkbse);
+  else
+    scm_egc();
   ALLOW_INTS;
   return UNSPECIFIED;
 }
@@ -1316,21 +1803,25 @@ void igc(what, stackbase)
      STACKITEM *stackbase;
 {
   int j = num_protects;
-  long oheap_size = heap_size;
+  long oheap_cells = heap_cells;
   gc_start(what);
   if (++errjmp_bad > 1)
-    wta(MAKINUM(errjmp_bad), "gc called from within ", s_gc);
+    wta(MAKINUM(errjmp_bad), s_recursive, s_gc);
+#ifdef NUM_HP
+  num_hp_switch();	/* Switch half-heaps for flonums/bignums */
+#endif
+#ifdef NO_SYM_GC
+  gc_mark(symhash);
+#else
   /* By marking symhash first, we provide the best immunity from
      accidental references.  In order to accidentally protect a
      symbol, a pointer will have to point directly at the symbol (as
      opposed to the vector or bucket lists).  */
   mark_syms(symhash);
   /* mark_sym_values() can be called anytime after mark_syms.  */
-#ifdef NO_SYM_GC
-  gc_mark(symhash);
-#else
   mark_sym_values(symhash);
 #endif
+  egc_mark();
   if (stackbase) {
     FLUSH_REGISTER_WINDOWS;
     /* This assumes that all registers are saved into the jump_buf */
@@ -1360,14 +1851,24 @@ void igc(what, stackbase)
   }
   while(j--)
     gc_mark(sys_protects[j]);
+#ifndef NO_SYM_GC
   sweep_symhash(symhash);
+#endif
   gc_sweep(!stackbase);
+  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;
   gc_end();
-  if (oheap_size != heap_size) {
-    ALLOW_INTS;
-    growth_mon(s_heap, heap_size, s_cells);
-    DEFER_INTS;
+  if (oheap_cells != heap_cells) {
+    int grewp = heap_cells > oheap_cells;
+    growth_mon(s_numheaps, (long)(hplim_ind/2), s_segs, grewp);
+    growth_mon(s_heap, heap_cells, s_cells, grewp);
   }
 }
 
@@ -1377,7 +1878,8 @@ void free_storage()
   DEFER_INTS;
   gc_start("free");
   ++errjmp_bad;
-  cur_inp = BOOL_F; cur_outp = BOOL_F; cur_errp = PTR2SCM(&tmp_errp);
+  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 */
   gc_mark(def_errp);		/* don't want to close stderr */
@@ -1387,44 +1889,65 @@ void free_storage()
     hplim_ind -= 2;
     {
       CELLPTR ptr = CELL_UP(hplims[hplim_ind]);
-      sizet seg_size = CELL_DN(hplims[hplim_ind+1]) - ptr;
-      heap_size -= seg_size;
-      must_free((char *)hplims[hplim_ind]);
+      sizet seg_cells = CELL_DN(hplims[hplim_ind+1]) - ptr;
+      heap_cells -= seg_cells;
+      free((char *)hplims[hplim_ind]);
       hplims[hplim_ind] = 0;
-      growth_mon(s_heap, heap_size, s_cells);
+      growth_mon(s_heap, heap_cells, s_cells, 0); fflush(stderr);
     }}
-  if (heap_size) wta(MAKINUM(heap_size), s_not_free, s_heap);
+  if (heap_cells) wta(MAKINUM(heap_cells), s_not_free, s_heap);
   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"); */
-  must_free((char *)hplims);
   hplims = 0;
-  must_free((char *)smobs);
+  /*  must_free((char *)smobs, numsmob * sizeof(smobfuns)); */
+  free((char *)smobs);
   smobs = 0;
-  gc_end();
+  gc_end(); 
   ALLOW_INTS; /* A really bad idea, but printing does it anyway. */
   exit_report();
-  must_free((char *)ptobs);
+  lflush(sys_errp);
+  /* must_free((char *)ptobs, numptob * sizeof(ptobfuns)); */
+  free((char *)ptobs);
   ptobs = 0;
   lmallocated = mallocated = 0;
   /* Can't do gc_end() here because it uses ptobs which have been freed */
+  fflush(stdout);		/* in lieu of close */
+  fflush(stderr);		/* in lieu of close */
+}
+
+#define HUGE_LENGTH(x) (LENGTH_MAX==LENGTH(x) ? *((long *)VELTS(x)) : LENGTH(x))
+
+/* This is used to force allocation of SCM temporaries on the stack,
+   it should be called with any SCM variables used for malloc headers
+   and entirely local to a C procedure.  */
+void scm_protect_temp(ptr)
+     SCM *ptr;
+{
+  return;
 }
 
+static char s_gc_sym[] = "mark_syms", s_wrong_length[] = "wrong length";
 void gc_mark(p)
      SCM p;
 {
   register long i;
   register SCM ptr = p;
+  CHECK_STACK;
  gc_mark_loop:
   if IMP(ptr) return;
  gc_mark_nimp:
   if (NCELLP(ptr)
-      /* #ifndef RECKLESS
-	 || PTR_GT(hplims[0], (CELLPTR)ptr)
-	 || PTR_GE((CELLPTR)ptr, hplims[hplim_ind-1])
-#endif */
+      /* #ifndef RECKLESS */
+      /* || PTR_GT(hplims[0], (CELLPTR)ptr) */
+      /* || PTR_GE((CELLPTR)ptr, hplims[hplim_ind-1]) */
+      /* #endif */
       ) wta(ptr, "rogue pointer in ", s_heap);
   switch TYP7(ptr) {
   case tcs_cons_nimcar:
@@ -1446,17 +1969,28 @@ void gc_mark(p)
   case tcs_closures:
     if GCMARKP(ptr) break;
     SETGCMARK(ptr);
-    if IMP(CDR(ptr)) {
+    if IMP(GCENV(ptr)) {
       ptr = CODE(ptr);
       goto gc_mark_nimp;
     }
     gc_mark(CODE(ptr));
-    ptr = GCCDR(ptr);
+    ptr = GCENV(ptr);
     goto gc_mark_nimp;
-  case tc7_vector:
+  case tc7_specfun:
+    if GC8MARKP(ptr) break;
+    SETGC8MARK(ptr);
 #ifdef CCLO
-  case tc7_cclo:
+    if (tc16_cclo==GCTYP16(ptr)) {
+      i = CCLO_LENGTH(ptr);
+      if (i==0) break;
+      while(--i>0) if NIMP(VELTS(ptr)[i]) gc_mark(VELTS(ptr)[i]);
+      ptr = VELTS(ptr)[0];
+    }
+    else
 #endif
+      ptr = CDR(ptr);
+    goto gc_mark_loop;
+  case tc7_vector:
     if GC8MARKP(ptr) break;
     SETGC8MARK(ptr);
     i = LENGTH(ptr);
@@ -1472,15 +2006,18 @@ void gc_mark(p)
 			   (sizeof(STACKITEM) - 1 + sizeof(CONTINUATION)) /
 			   sizeof(STACKITEM)));
     break;
+  case tc7_string:
+  case tc7_msymbol:
+    if GC8MARKP(ptr) break;
+    ASSERT(!(CHARS(ptr)[HUGE_LENGTH(ptr)]), MAKINUM(HUGE_LENGTH(ptr)),
+	   s_wrong_length, s_gc);
+  case tc7_ssymbol:
   case tc7_bvect:
   case tc7_ivect:
   case tc7_uvect:
   case tc7_fvect:
   case tc7_dvect:
   case tc7_cvect:
-  case tc7_string:
-  case tc7_msymbol:
-  case tc7_ssymbol:
     SETGC8MARK(ptr);
   case tcs_subrs:
     break;
@@ -1495,12 +2032,46 @@ void gc_mark(p)
     case tc_free_cell:
       /* printf("found free_cell %X ", ptr); fflush(stdout); */
       SETGC8MARK(ptr);
-      CDR(ptr) = EOL;
+      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;
@@ -1541,8 +2112,6 @@ void mark_locations(x, n)
 	}
 }
 
-#define HUGE_LENGTH(x) (LENGTH_MAX==LENGTH(x) ? *((long *)VELTS(x)) : LENGTH(x))
-
 static void gc_sweep(contin_bad)
      int contin_bad;
 {
@@ -1550,17 +2119,17 @@ static void gc_sweep(contin_bad)
 #ifdef POINTERS_MUNGED
   register SCM scmptr;
 #else
-#define scmptr (SCM)ptr
+# define scmptr (SCM)ptr
 #endif
   register SCM nfreelist = EOL;
   register long n = 0, m = 0;
-  register sizet j;
+  register sizet j, minc;
   sizet i = 0;
-  sizet seg_size;
+  sizet seg_cells;
   while (i<hplim_ind) {
     ptr = CELL_UP(hplims[i++]);
-    seg_size = CELL_DN(hplims[i++]) - ptr;
-    for(j = seg_size;j--;++ptr) {
+    seg_cells = CELL_DN(hplims[i++]) - ptr;
+    for(j = seg_cells;j--;++ptr) {
 #ifdef POINTERS_MUNGED
       scmptr = PTR2SCM(ptr);
 #endif
@@ -1571,44 +2140,51 @@ static void gc_sweep(contin_bad)
       case tcs_closures:
 	if GCMARKP(scmptr) goto cmrkcontinue;
 	break;
-      case tc7_vector:
+      case tc7_specfun:
+	if GC8MARKP(scmptr) goto c8mrkcontinue;
 #ifdef CCLO
-      case tc7_cclo:
+	if (tc16_cclo==GCTYP16(scmptr)) {
+	  minc = (CCLO_LENGTH(scmptr)*sizeof(SCM));
+	  goto freechars;
+	}
 #endif
+	break;
+      case tc7_vector:
 	if GC8MARKP(scmptr) goto c8mrkcontinue;
-	m += (LENGTH(scmptr)*sizeof(SCM));
+	minc = (LENGTH(scmptr)*sizeof(SCM));
       freechars:
-	must_free(CHARS(scmptr));
+	m += minc;
+	must_free(CHARS(scmptr), minc);
 /*	SETCHARS(scmptr, 0);*/
 	break;
       case tc7_bvect:
 	if GC8MARKP(scmptr) goto c8mrkcontinue;
-	m += sizeof(long)*((HUGE_LENGTH(scmptr)+LONG_BIT-1)/LONG_BIT);
+	minc = sizeof(long)*((HUGE_LENGTH(scmptr)+LONG_BIT-1)/LONG_BIT);
 	goto freechars;
       case tc7_ivect:
       case tc7_uvect:
 	if GC8MARKP(scmptr) goto c8mrkcontinue;
-	m += HUGE_LENGTH(scmptr)*sizeof(long);
+	minc = HUGE_LENGTH(scmptr)*sizeof(long);
 	goto freechars;
       case tc7_fvect:
 	if GC8MARKP(scmptr) goto c8mrkcontinue;
-	m += HUGE_LENGTH(scmptr)*sizeof(float);
+	minc = HUGE_LENGTH(scmptr)*sizeof(float);
 	goto freechars;
       case tc7_dvect:
 	if GC8MARKP(scmptr) goto c8mrkcontinue;
-	m += HUGE_LENGTH(scmptr)*sizeof(double);
+	minc = HUGE_LENGTH(scmptr)*sizeof(double);
 	goto freechars;
       case tc7_cvect:
 	if GC8MARKP(scmptr) goto c8mrkcontinue;
-	m += HUGE_LENGTH(scmptr)*2*sizeof(double);
+	minc = HUGE_LENGTH(scmptr)*2*sizeof(double);
 	goto freechars;
       case tc7_string:
 	if GC8MARKP(scmptr) goto c8mrkcontinue;
-	m += HUGE_LENGTH(scmptr)+1;
+	minc = HUGE_LENGTH(scmptr)+1;
 	goto freechars;
       case tc7_msymbol:
 	if GC8MARKP(scmptr) goto c8mrkcontinue;
-	m += LENGTH(scmptr)+1;
+	minc = LENGTH(scmptr)+1;
 	goto freechars;
       case tc7_contin:
 	if GC8MARKP(scmptr) {
@@ -1620,7 +2196,7 @@ static void gc_sweep(contin_bad)
 	  }
 	  goto c8mrkcontinue;
 	}
-	m += LENGTH(scmptr)*sizeof(STACKITEM) + sizeof(CONTINUATION);
+	minc = LENGTH(scmptr)*sizeof(STACKITEM) + sizeof(CONTINUATION);
 	free_continuation(CONT(scmptr)); break; /* goto freechars; */
       case tc7_ssymbol:
 	if GC8MARKP(scmptr) goto c8mrkcontinue;
@@ -1651,30 +2227,38 @@ static void gc_sweep(contin_bad)
 #ifdef BIGDIG
 	case tcs_bignums:
 	  if GC8MARKP(scmptr) goto c8mrkcontinue;
-	  m += (NUMDIGS(scmptr)*BITSPERDIG/CHAR_BIT);
+# ifdef NUM_HP
+	  if (NUMDIGS(scmptr)*sizeof(BIGDIG) <= NUM_HP_MAX_REQ) break;
+# endif /* def NUM_HP */
+	  minc = (NUMDIGS(scmptr)*BITSPERDIG/CHAR_BIT);
 	  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:
-	    m += sizeof(double);
+	    minc = 2*sizeof(double);
+	    goto freechars;
 	  case REAL_PART>>16:
 	  case IMAG_PART>>16:
-	    m += sizeof(double);
+	    minc = sizeof(double);
 	    goto freechars;
 	  case 0:
 	    break;
 	  default:
 	    goto sweeperr;
 	  }
+# endif /* ndef NUM_HP */
+#endif /* def FLOATS */
 	  break;
 	default:
 	  if GC8MARKP(scmptr) goto c8mrkcontinue;
 	  {
 	    int k = SMOBNUM(scmptr);
 	    if (!(k < numsmob)) goto sweeperr;
-	    m += (smobs[k].free)((CELLPTR)scmptr);
+	    minc = (smobs[k].free)((CELLPTR)scmptr);
 	  }
 	}
 	break;
@@ -1692,9 +2276,12 @@ static void gc_sweep(contin_bad)
       CLRGCMARK(scmptr);
     }
 #ifdef GC_FREE_SEGMENTS
-    if (n==seg_size) {
-      heap_size -= seg_size;
-      must_free((char *)hplims[i-2]);
+    if (n==seg_cells) {
+      heap_cells -= seg_cells;
+      n = 0;
+      free((char *)hplims[i-2]);
+      /*      must_free((char *)hplims[i-2],
+		sizeof(cell) * (hplims[i-1] - hplims[i-2])); */
       hplims[i-2] = 0;
       for(j = i;j < hplim_ind;j++) hplims[j-2] = hplims[j];
       hplim_ind -= 2;
@@ -1707,16 +2294,16 @@ static void gc_sweep(contin_bad)
     gc_cells_collected += n;
     n = 0;
   }
-  lcells_allocated += (heap_size - gc_cells_collected - cells_allocated);
-  cells_allocated = (heap_size - gc_cells_collected);
+  lcells_allocated += (heap_cells - gc_cells_collected - cells_allocated);
+  cells_allocated = (heap_cells - gc_cells_collected);
   lmallocated -= m;
   mallocated -= m;
   gc_malloc_collected = m;
 }
 
+#ifndef NO_SYM_GC
 /* mark_syms marks those symbols of hash table V which have
    non-UNDEFINED values.  */
-static char s_gc_sym[] = "mark_syms";
 static void mark_syms(v)
      SCM v;
 {
@@ -1728,7 +2315,14 @@ static void mark_syms(v)
       ASSERT(!GCMARKP(al), al, s_bad_type, s_gc_sym);
       x = CAR(al);
       SETGCMARK(al);		/* Do mark bucket list */
-      ASSERT(!GCMARKP(x), x, s_bad_type, s_gc_sym);
+# ifdef CAREFUL_INTS
+      ASSERT(NIMP(x) && NIMP(CAR(x)) && !GCMARKP(x), x, s_bad_type, s_gc_sym);
+      ASSERT(!GC8MARKP(CAR(x)) && !(CHARS(CAR(x))[LENGTH(CAR(x))]),
+	     CAR(x), s_wrong_length, s_gc_sym);
+      ASSERT(strhash(UCHARS(CAR(x)), (sizet)LENGTH(CAR(x)),
+		     (unsigned long)symhash_dim)==k,
+	     CAR(x), "bad hash", s_gc_sym);
+# endif
       if (UNDEFINED==CDR(x) && tc7_msymbol==TYP7(CAR(x)))
 	goto used;		/* Don't mark symbol.  */
       SETGC8MARK(CAR(x));
@@ -1747,7 +2341,7 @@ static void mark_sym_values(v)
 {
   SCM x, al;
   int k = LENGTH(v);
-  SETGC8MARK(v);
+  /* SETGC8MARK(v); */		/* already set by mark_syms */
   while (k--)
     for (al = VELTS(v)[k]; NIMP(al); al = GCCDR(al)) {
       x = GCCDR(CAR(al));
@@ -1780,3 +2374,172 @@ static void sweep_symhash(v)
     VELTS(v)[k] &= ~1L;		/* We may have deleted the first cell */
   }
 }
+#endif
+
+/* Environment cache GC routines */
+/* This is called during a non-cache gc. We only mark those stack frames
+   that are in use. */
+static void egc_mark()
+{
+  SCM *v;
+  int i;
+  gc_mark(scm_env);
+  gc_mark(scm_env_tmp);
+  if IMP(scm_estk) return;	/* Can happen when moving estk. */
+  if GC8MARKP(scm_estk) return;	
+  v = VELTS(scm_estk);
+  SETGC8MARK(scm_estk);
+  i = scm_estk_ptr - v + SCM_ESTK_FRLEN;
+  while(--i >= 0)
+    if NIMP(v[i])
+      gc_mark(v[i]);
+}
+static void egc_sweep()
+{
+  SCM z;
+  int i;
+  for (i = scm_ecache_index; i < scm_ecache_len; i++) {
+    z = PTR2SCM(&(scm_ecache[i]));
+    if CONSP(z) {
+      CLRGCMARK(z);
+    }
+    else {
+      CLRGC8MARK(z);
+    }
+  }
+}
+
+#define ECACHEP(x) (PTR_LE((CELLPTR)(ecache_v), (CELLPTR)SCM2PTR(x)) && \
+		    PTR_GT((CELLPTR)(ecache_v) + ECACHE_SIZE, (CELLPTR)SCM2PTR(x)))
+static void egc_copy(px)
+     SCM *px;
+{
+  SCM z, x = *px;
+  do {
+    if (tc_broken_heart==CAR(x)) {
+      *px = CDR(x);
+      return;
+    }
+    if IMP(freelist) wta(freelist, "empty freelist", "ecache gc");
+    z = freelist;
+    freelist = CDR(freelist);
+    ++cells_allocated;
+    CAR(z) = CAR(x);
+    CDR(z) = CDR(x);
+    CAR(x) = (SCM)tc_broken_heart;
+    CDR(x) = z;
+    *px = z;
+    x = CAR(z);
+    if (NIMP(x) && ECACHEP(x))
+      egc_copy(&(CAR(z)));
+    px = &(CDR(z));
+    x = *px;
+  } while (NIMP(x) && ECACHEP(x));
+}
+
+static void egc_copy_stack(ve, len)
+     SCM *ve;
+     sizet len;
+{
+  SCM x;
+  while (len--) {
+    x = ve[len];
+    if (NIMP(x) && ECACHEP(x))
+      if (tc_broken_heart==CAR(x))
+	ve[len] = CDR(x);
+      else
+	egc_copy(&(ve[len]));
+  }
+}
+
+extern long tc16_env, tc16_promise;
+static void egc_copy_roots()
+{
+  SCM *roots = &(scm_egc_roots[scm_egc_root_index]);
+  SCM e, x;
+  int len = sizeof(scm_egc_roots)/sizeof(SCM) - scm_egc_root_index ;
+  if (!(len>=0 && len <= sizeof(scm_egc_roots)/sizeof(SCM)))
+    wta(MAKINUM(scm_egc_root_index), "egc-root-index", "corrupted");
+  while (len--) {
+    x = roots[len];
+    if IMP(x) continue;
+    switch TYP3(x) {
+    clo:
+    case tc3_closure:
+      e = ENV(x);
+      if (NIMP(e) && ECACHEP(e)) {
+	egc_copy(&e);
+	CDR(x) = (6L & CDR(x)) | e;
+      }
+      break;
+    case tc3_cons_imcar:
+    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 
+				   cache. */
+      if ECACHEP(x) break;
+      e = CDR(x);
+      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));
+	break;
+      }
+      if (tc16_env==CAR(x)) {
+	e = CDR(x);
+	if (NIMP(e) && ECACHEP(e))
+	  egc_copy(&(CDR(x)));
+	break;
+      }
+      if (tc16_promise==CAR(x)) {
+	x = CDR(x);
+	goto clo;
+      }
+    }
+  }
+  scm_egc_root_index = sizeof(scm_egc_roots)/sizeof(SCM);
+}
+extern long scm_stk_moved, scm_clo_moved, scm_env_work;
+void scm_egc()
+{
+  VERIFY_INTS("scm_egc", 0);
+/* 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)) {
+    igc("ecache", CONT(rootcont)->stkbse);
+    if ((gc_cells_collected < MIN_GC_YIELD) ||
+	(heap_cells - cells_allocated <= scm_ecache_len) || IMP(freelist)) {
+      alloc_some_heap();
+      growth_mon("number of heaps", (long)(hplim_ind/2), "segments", !0);
+      growth_mon(s_heap, heap_cells, s_cells, !0);
+    }
+  }
+  if (++errjmp_bad > 1)
+    wta(MAKINUM(errjmp_bad), s_recursive, s_cache_gc);
+  {
+    SCM stkframe[2];
+    long lcells = cells_allocated;
+    sizet nstk = (scm_estk_ptr - VELTS(scm_estk) + SCM_ESTK_FRLEN);
+    ASSERT(nstk<=LENGTH(scm_estk), UNDEFINED, "estk corrupted", s_cache_gc);
+    scm_egc_start();
+    stkframe[0] = scm_env;
+    stkframe[1] = scm_env_tmp;
+    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);
+    scm_env = stkframe[0];
+    scm_env_tmp = stkframe[1];
+    scm_stk_moved += cells_allocated - lcells;
+    scm_ecache_index = scm_ecache_len;
+    scm_env_work += scm_ecache_len;
+    scm_egc_end();
+  }
+  --errjmp_bad;
+}
+