/* 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.
 *
 * As a special exception, the Free Software Foundation gives permission
 * for additional uses of the text contained in its release of GUILE.
 *
 * The exception is that, if you link the GUILE library with other files
 * to produce an executable, this does not by itself cause the
 * resulting executable to be covered by the GNU General Public License.
 * Your use of that executable is in no way restricted on account of
 * linking the GUILE library code into it.
 *
 * This exception does not however invalidate any other reasons why
 * the executable file might be covered by the GNU General Public License.
 *
 * This exception applies only to the code released by the
 * Free Software Foundation under the name GUILE.  If you copy
 * code from other Free Software Foundation releases into a copy of
 * GUILE, as the General Public License permits, the exception does
 * not apply to the code that you add in this way.  To avoid misleading
 * anyone as to the status of such modified files, you must delete
 * this exception notice from them.
 *
 * If you write modifications of your own for GUILE, it is your choice
 * whether to permit this exception to apply to your modifications.
 * If you do not wish that, delete this exception notice.  
 */

/* "sys.c" opening and closing files, storage, and GC. */

#include <ctype.h>

#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. */

#ifndef STDC_HEADERS
	char *ttyname P((int fd));
	char *tmpnam P((char *s));
	sizet fwrite ();
# ifdef sun
#  ifndef __svr4__
        int fputs P((char *s, FILE* stream));
        int fputc P((char c, FILE* stream));
        int fflush P((FILE* stream));
#  endif
# endif
	int fgetc P((FILE* stream));
	int fclose P((FILE* stream));
	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_try_open_file[] = "try-open-file";
#define	s_open_file (&s_try_open_file[4])
char	s_close_port[] = "close-port";

#ifdef __IBMC__
# include <io.h>
# include <direct.h>
# define ttyname(x) "CON:"
#else
# ifndef MSDOS
#  ifndef ultrix
#   ifndef vms
#    ifdef _DCC
#     include <ioctl.h>
#     define setbuf(stream, buf) setvbuf(stream, buf, _IONBF, 0)
#    else
#     ifdef MWC
#      include <sys/io.h>
#     else
#      ifndef macintosh
#       ifndef ARM_ULIB
#        include <sys/ioctl.h>
#       endif
#      endif
#     endif
#    endif
#   endif
#  endif
# endif
#endif /* __IBMC__ */
SCM i_setbuf0(port)		/* should be called with DEFER_INTS active */
     SCM port;
{
#ifndef NOSETBUF
# ifndef MSDOS
#  ifdef FIONREAD
#   ifndef ultrix
  SYSCALL(setbuf(STREAM(port), 0););
#   endif
#  endif
# endif
#endif
  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);
}

SCM try_open_file(filename, modes)
     SCM filename, modes;
{
  register SCM port;
  FILE *f;
  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);
  }
  ALLOW_INTS;
  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;
{
	sizet i;
	ASSERT(NIMP(port) && PORTP(port), port, ARG1, s_close_port);
	if CLOSEDP(port) return UNSPECIFIED;
	i = PTOBNUM(port);
	DEFER_INTS;
	if (ptobs[i].fclose) {
	  SYSCALL((ptobs[i].fclose)(STREAM(port)););
	}
	CAR(port) &= ~OPN;
	ALLOW_INTS;
	return UNSPECIFIED;
}
SCM input_portp(x)
     SCM x;
{
	if IMP(x) return BOOL_F;
	return INPORTP(x) ? BOOL_T : BOOL_F;
}
SCM output_portp(x)
     SCM x;
{
	if IMP(x) return BOOL_F;
	return OUTPORTP(x) ? BOOL_T : BOOL_F;
}

#if (__TURBOC__==1)
# undef L_tmpnam		/* Not supported in TURBOC V1.0 */
#endif
#ifdef GO32
# undef L_tmpnam
#endif
#ifdef MWC
# undef L_tmpnam
#endif

#ifdef L_tmpnam
SCM ltmpnam()
{
  char name[L_tmpnam];
  SYSCALL(tmpnam(name););
  return makfrom0str(name);
}
#else
/* TEMPTEMPLATE is used only if mktemp() is being used instead of
   tmpnam(). */

# ifdef AMIGA
#  define TEMPTEMPLATE "T:SchemeaaaXXXXXX";
# else
#  ifdef vms
#   define TEMPTEMPLATE "sys$scratch:aaaXXXXXX";
#  else /* vms */
#   ifdef __MSDOS__
#    ifdef GO32
#     define TEMPTEMPLATE "\\tmp\\TMPaaaXXXXXX";
#    else
#     define TEMPTEMPLATE "TMPaaaXXXXXX";
#    endif
#   else /* __MSDOS__ */
#    define TEMPTEMPLATE "/tmp/aaaXXXXXX";
#   endif /* __MSDOS__ */
#  endif /* vms */
# endif /* AMIGA */

char template[] = TEMPTEMPLATE;
# define TEMPLEN (sizeof template/sizeof(char) - 1)
SCM ltmpnam()
{
  SCM name;
  int temppos = TEMPLEN-9;
  name = makfromstr(template, (sizet)TEMPLEN);
  DEFER_INTS;
inclp:
  template[temppos]++;
  if (!isalpha(template[temppos])) {
    template[temppos++] = 'a';
    goto inclp;
  }
# ifndef AMIGA
#  ifndef __MSDOS__
  SYSCALL(temppos = !*mktemp(CHARS(name)););
  if (temppos) name = BOOL_F;
#  endif
# endif
  ALLOW_INTS;
  return name;
}
#endif /* L_tmpnam */

#ifdef M_SYSV
# define remove unlink
#endif
static char s_del_fil[] = "delete-file";
SCM del_fil(str)
     SCM str;
{
  int ans;
  ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_del_fil);
#ifdef STDC_HEADERS
  SYSCALL(ans = remove(CHARS(str)););
#else
  SYSCALL(ans = unlink(CHARS(str)););
#endif
  return ans ? BOOL_F : BOOL_T;
}

void prinport(exp, port, type)
     SCM exp; SCM port; char *type;
{
  lputs("#<", port);
  if CLOSEDP(exp) lputs("closed-", port);
  else {
    if (RDNG & CAR(exp)) lputs("input-", port);
    if (WRTNG & CAR(exp)) lputs("output-", port);
  }
  lputs(type, port);
  lputc(' ', port);
#ifndef MSDOS
# ifndef __EMX__
#  ifndef _DCC
#   ifndef AMIGA
#    ifndef macintosh
  if (OPENP(exp) && tc16_fport==TYP16(exp) && isatty(fileno(STREAM(exp))))
    lputs(ttyname(fileno(STREAM(exp))), port);
  else
#    endif
#   endif
#  endif
# endif
#endif
    if OPFPORTP(exp) intprint((long)fileno(STREAM(exp)), 10, port);
    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;
{
  sizet ind = INUM(CAR(p));
  if (ind >= LENGTH(CDR(p))) resizuve(CDR(p), MAKINUM(ind + (ind>>1)));
  CHARS(CDR(p))[ind] = c;
  CAR(p) = MAKINUM(ind + 1);
  return c;
}
sizet stwrite(str, siz, num, p)
     sizet siz, num;
     char *str; SCM p;
{
  sizet ind = INUM(CAR(p));
  sizet len = siz * num;
  char *dst;
  if (ind + len >= LENGTH(CDR(p)))
    resizuve(CDR(p), MAKINUM(ind + len + ((ind + len)>>1)));
  dst = &(CHARS(CDR(p))[ind]);
  while (len--) dst[len] = str[len];
  CAR(p) = MAKINUM(ind + siz*num);
  return num;
}
static int stputs(s, p)
     char *s; SCM p;
{
  stwrite(s, 1, strlen(s), p);
  return 0;
}
static int stgetc(p)
     SCM p;
{
  sizet ind = INUM(CAR(p));
  if (ind >= LENGTH(CDR(p))) return EOF;
  CAR(p) = MAKINUM(ind + 1);
  return UCHARS(CDR(p))[ind];
}
int noop0(stream)
     FILE *stream;
{
  return 0;
}
SCM mkstrport(pos, str, modes, caller)
     SCM pos;
     SCM str;
     long modes;
     char *caller;
{
  SCM z;
  ASSERT(INUMP(pos) && INUM(pos) >= 0, pos, ARG1, caller);
  ASSERT(NIMP(str) && (STRINGP(str) || SYMBOLP(str)), str, ARG1, caller);
  str = cons(pos, str);
  NEWCELL(z);
  DEFER_INTS;
  SETCHARS(z, str);
  CAR(z) = tc16_strport | modes;
  ALLOW_INTS;
  return z;
}
static char s_cwos[] = "call-with-output-string";
static char s_cwis[] = "call-with-input-string";
SCM cwos(proc)
     SCM proc;
{
  SCM p = mkstrport(INUM0, make_string(MAKINUM(30), UNDEFINED),
		    OPN | WRTNG,
		    s_cwos);
  apply(proc, p, listofnull);
  return resizuve(CDR(CDR(p)), CAR(CDR(p)));
}
SCM cwis(str, proc)
     SCM str, proc;
{
  SCM p = mkstrport(INUM0, str, OPN | RDNG, s_cwis);
  return apply(proc, p, listofnull);
}
#ifdef vms
sizet pwrite(ptr, size, nitems, port)
     char *ptr;
     sizet size, nitems;
     FILE* port;
{
  sizet len = size * nitems;
  sizet i = 0;
  for(;i < len;i++) putc(ptr[i], port);
  return len;
}
# define ffwrite pwrite
#else
# define ffwrite fwrite
#endif

static ptobfuns fptob = {
  mark0,
  fclose,
  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};
ptobfuns pipob = {
  mark0,
  0, 				/* replaced by pclose in init_ioext() */
  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() */
static ptobfuns stptob = {
  markcdr,
  noop0,
  prinstpt,
  0,
  stputc,
  stputs,
  stwrite,
  noop0,
  stgetc,
  0};

				/* Soft ports */

/* fputc, fwrite, fputs, and fclose are called within a
   SYSCALL.  So we need to set errno to 0 before returning.  fflush
   may be called within a SYSCALL.  So we need to set errno to 0
   before returning. */

static int sfputc(c, p)
     int c; SCM p;
{
  apply(VELTS(p)[0], MAKICHR(c), listofnull);
  errno = 0;
  return c;
}
sizet sfwrite(str, siz, num, p)
     sizet siz, num;
     char *str; SCM p;
{
  SCM sstr;
  sstr = makfromstr(str, siz * num);
  apply(VELTS(p)[1], sstr, listofnull);
  errno = 0;
  return num;
}
static int sfputs(s, p)
     char *s; SCM p;
{
  sfwrite(s, 1, strlen(s), p);
  return 0;
}
int sfflush(stream)
     SCM stream;
{
  SCM f = VELTS(stream)[2];
  if (BOOL_F==f) return 0;
  f = apply(f, EOL, EOL);
  errno = 0;
  return BOOL_F==f ? EOF : 0;
}
static int sfgetc(p)
     SCM p;
{
  SCM ans;
  ans = apply(VELTS(p)[3], EOL, EOL);
  errno = 0;
  if (FALSEP(ans) || EOF_VAL==ans) return EOF;
  ASSERT(ICHRP(ans), ans, ARG1, "getc");
  return ICHR(ans);
}
static int sfclose(p)
     SCM p;
{
  SCM f = VELTS(p)[4];
  if (BOOL_F==f) return 0;
  f = apply(f, EOL, EOL);
  errno = 0;
  return BOOL_F==f ? EOF : 0;
}
static char s_mksfpt[] = "make-soft-port";
SCM mksfpt(pv, modes)
     SCM pv, modes;
{
  SCM z;
  ASSERT(NIMP(pv) && VECTORP(pv) && 5==LENGTH(pv), pv, ARG1, s_mksfpt);
  ASSERT(NIMP(modes) && STRINGP(modes), modes, ARG2, s_mksfpt);
  NEWCELL(z);
  DEFER_INTS;
  CAR(z) = tc16_sfport | mode_bits(CHARS(modes));
  SETSTREAM(z, pv);
  ALLOW_INTS;
  return z;
}

static ptobfuns sfptob = {
  markcdr,
  noop0,
  prinsfpt,
  0,
  sfputc,
  sfputs,
  sfwrite,
  sfflush,
  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,
  freeprint,
  0};
static smobfuns flob = {
  mark0,
  /*flofree*/0,
  floprint,
  floequal};
static smobfuns bigob = {
  mark0,
  /*bigfree*/0,
  bigprint,
  bigequal};
void (**finals)() = 0;
sizet num_finals = 0;
static char s_final[] = "final";

void init_types()
{
  numptob = 0;
  ptobs = (ptobfuns *)malloc(4*sizeof(ptobfuns));
  /* 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));
  /* 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;
}

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;
}

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}, */
	{"tmpnam", ltmpnam},
	{0, 0}};

static iproc subr1s[] = {
	{s_input_portp, input_portp},
	{s_output_portp, output_portp},
	{s_close_port, close_port},
	{"eof-object?", eof_objectp},
	{s_cwos, cwos},
	{"object-hash", obhash},
	{s_obunhash, obunhash},
	{s_del_fil, del_fil},
	{0, 0}};

static iproc subr2s[] = {
	{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()
{
  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))));
  add_feature("string-port");
#ifndef CHEAP_CONTINUATIONS
  add_feature("full-continuation");
#endif
}

void grew_lim(nm)
     long nm;
{
  growth_mon(s_limit, nm, "bytes", !0);
}
int expmem = 0;
sizet hplim_ind = 0;
long heap_cells = 0;
CELLPTR *hplims, heap_org;
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;
  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;
  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) {
#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 unused, UNDEFINED
				   symbols.*/
int symhash_dim = NUM_HASH_BUCKETS;
/* sym2vcell looks up the symbol in the symhash table. */
SCM sym2vcell(sym)
     SCM sym;
{
  SCM lsym, z;
  sizet hash = strhash(UCHARS(sym), (sizet)LENGTH(sym),
		       (unsigned long)symhash_dim);
  for(lsym = VELTS(symhash)[hash];NIMP(lsym);lsym = CDR(lsym)) {
    z = CAR(lsym);
    if (CAR(z)==sym) return z;
  }
  wta(sym, "uninterned symbol? ", "");
}
/* intern() and sysintern() return a pair;
   CAR is the symbol, CDR is the value. */
SCM intern(name, len)
     char *name;
     sizet len;
{
  SCM lsym, z;
  register sizet i = len;
  register unsigned char *tmp = (unsigned char *)name;
  sizet hash = strhash(tmp, i, (unsigned long)symhash_dim);
  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;
    return CAR(lsym);
  trynext: ;
  }
  lsym = makfromstr(name, len);
  DEFER_INTS;
  SETLENGTH(lsym, (long)len, tc7_msymbol);
  ALLOW_INTS;
  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);
  ALLOW_INTS;
  return z;
}
SCM sysintern(name, val)
     const char *name;
     SCM val;
{
  SCM lsym, z;
  sizet len = strlen(name);
  register sizet i = len;
  register unsigned char *tmp = (unsigned char *)name;
  sizet hash = strhash(tmp, i, (unsigned long)symhash_dim);
  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;
    lsym = CAR(lsym);
    CDR(lsym) = val;
    return lsym;
  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];
  VELTS(symhash)[hash] = z;
  return lsym;
}
SCM cons(x, y)
     SCM x, y;
{
	register SCM z;
	NEWCELL(z);
	CAR(z) = x;
	CDR(z) = y;
	return z;
}
SCM cons2(w, x, y)
     SCM w, x, y;
{
	register SCM z;
	NEWCELL(z);
	CAR(z) = x;
	CDR(z) = y;
	x = z;
	NEWCELL(z);
	CAR(z) = w;
	CDR(z) = x;
	return z;
}
SCM acons(w, x, y)
     SCM w, x, y;
{
	register SCM z;
	NEWCELL(z);
	CAR(z) = w;
	CDR(z) = x;
	x = z;
	NEWCELL(z);
	CAR(z) = x;
	CDR(z) = y;
	return z;
}

SCM makstr(len)
     long len;
{
	SCM s;
	DEFER_INTS;
	s = must_malloc_cell(len+1, s_string);
	SETLENGTH(s, len, tc7_string);
	CHARS(s)[len] = 0;
   	ALLOW_INTS;
	return s;
}

SCM make_subr(name, type, fcn)
     const char *name;
     int type;
     SCM (*fcn)();
{
	SCM symcell = sysintern(name, UNDEFINED);
	long tmp = ((((CELLPTR)(CAR(symcell)))-heap_org)<<8);
	register SCM z;
	if ((tmp>>8) != ((CELLPTR)(CAR(symcell))-heap_org))
	  tmp = 0;
	NEWCELL(z);
	CAR(z) = tmp + type;
	SUBRF(z) = fcn;
	CDR(symcell) = z;
	return z;
}

#ifdef CCLO
SCM makcclo(proc, len)
     SCM proc;
     long len;
{
  SCM s;
  DEFER_INTS;
  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;
  return s;
}
#endif

#ifdef STACK_LIMIT
void stack_check()
{
  STACKITEM *start = CONT(rootcont)->stkbse;
  STACKITEM stack;
# ifdef STACK_GROWS_UP
  if (&stack - start > STACK_LIMIT/sizeof(STACKITEM))
# else
  if (start - &stack > STACK_LIMIT/sizeof(STACKITEM))
# endif /* def STACK_GROWS_UP */
    {
      stack_report();
      wta(UNDEFINED, (char *)SEGV_SIGNAL, "stack");
    }
}
#endif
void stack_report()
{
  STACKITEM stack;
  lputs(";; stack: 0x", cur_errp);
  intprint((long)CONT(rootcont)->stkbse, -16, cur_errp);
  lputs(" - 0x", 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)
     SCM thunk1, thunk2, thunk3;
{
  SCM ans;
  apply(thunk1, EOL, EOL);
  dynwinds = acons(thunk1, thunk3, dynwinds);
  ans = apply(thunk2, EOL, EOL);
  dynwinds = CDR(dynwinds);
  apply(thunk3, EOL, EOL);
  return ans;
}
void dowinds(to, delta)
     SCM to;
     long delta;
{
 tail:
  if (dynwinds==to);
  else if (0 > delta) {
    dowinds(CDR(to), 1+delta);
    apply(CAR(CAR(to)), EOL, EOL);
    dynwinds = to;
  }
  else {
    SCM from = CDR(CAR(dynwinds));
    dynwinds = CDR(dynwinds);
    apply(from, EOL, EOL);
    delta--; goto tail;		/* dowinds(to, delta-1); */
  }
}

/* Remember that setjump needs to be called after scm_make_cont */

SCM scm_make_cont()
{
  SCM cont, env, *from, *to;
  CONTINUATION *ncont;
  sizet n;
  VERIFY_INTS("scm_make_cont", 0);
  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];
  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;
  return cont;
}
static char s_sstale[] = "strangely stale";
void scm_dynthrow(cont, val)
     CONTINUATION *cont;
     SCM val;
{
  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));
  {
    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);
}

SCM obhash(obj)
     SCM obj;
{

#ifdef BIGDIG
  long n = SRS(obj, 1);
  if (!FIXABLE(n)) return long2big(n);
#endif
  return (obj<<1)+2L;
}

SCM obunhash(obj)
     SCM obj;
{
#ifdef BIGDIG
  if (NIMP(obj) && BIGP(obj)) {
    sizet i = NUMDIGS(obj);
    BIGDIG *ds = BDIGITS(obj);
    if (TYP16(obj)==tc16_bigpos) {
      obj = 0;
      while (i--) obj = BIGUP(obj) + ds[i];
    }
    else {
      obj = 0;
      while (i--) obj = BIGUP(obj) - ds[i];
    }
    obj <<= 1;
    goto comm;
  }
#endif
  ASSERT(INUMP(obj), obj, ARG1, s_obunhash);
  obj = SRS(obj, 1) & ~1L;
comm:
  if IMP(obj) return obj;
  if NCELLP(obj) return BOOL_F;
  {
    /* This code is adapted from mark_locations() in "sys.c" and
       scm_cell_p() in "rope.c", which means that changes to these
       routines must be coordinated. */
    register CELLPTR ptr = (CELLPTR)SCM2PTR(obj);
    register sizet i = 0, j = hplim_ind;
    do {
      if PTR_GT(hplims[i++], ptr) break;
      if PTR_LE(hplims[--j], ptr) break;
      if ((i != j)
	  && PTR_LE(hplims[i++], ptr)
	  && PTR_GT(hplims[--j], ptr)) continue;
      if NFREEP(obj) return obj;
      break;
    } while(i<j);
  }
  return BOOL_F;
}

unsigned long strhash(str, len, n)
     unsigned char *str;
     sizet len;
     unsigned long n;
{
  if (len>5)
    {
      sizet i = 5;
      unsigned long h = 264 % n;
      while (i--) h = ((h<<8) + ((unsigned)(downcase[str[h % len]]))) % n;
      return h;
    }
  else {
    sizet i = len;
    unsigned long h = 0;
    while (i) h = ((h<<8) + ((unsigned)(downcase[str[--i]]))) % n;
    return h;
  }
}

static void fixconfig(s1, s2, s)
     char *s1, *s2;
     int s;
{
  fputs(s1, stderr);
  fputs(s2, stderr);
  fputs("\nin ", stderr);
  fputs(s ? "setjump" : "scmfig", stderr);
  fputs(".h and recompile scm\n", stderr);
  quit(MAKINUM(1L));
}

sizet init_heap_seg(seg_org, size)
     CELLPTR seg_org;
     sizet size;
{
  register CELLPTR ptr = seg_org;
#ifdef POINTERS_MUNGED
  register SCM scmptr;
#else
# define scmptr ptr
#endif
  CELLPTR seg_end = CELL_DN((char *)ptr + size);
  sizet i = hplim_ind, ni = 0;
  if (ptr==NULL) return 0;
  while((ni < hplim_ind) && PTR_LE(hplims[ni], seg_org)) ni++;
  while(i-- > ni) hplims[i+2] = hplims[i];
  hplim_ind += 2;
  hplims[ni++] = ptr;		/* same as seg_org here */
  hplims[ni++] = seg_end;
  ptr = CELL_UP(ptr);
  ni = seg_end - ptr;
  for (i = ni;i--;ptr++) {
#ifdef POINTERS_MUNGED
    scmptr = PTR2SCM(ptr);
#endif
    CAR(scmptr) = (SCM)tc_free_cell;
    CDR(scmptr) = PTR2SCM(ptr+1);
  }
/*  CDR(scmptr) = freelist; */
  CDR(PTR2SCM(--ptr)) = freelist;
  freelist = PTR2SCM(CELL_UP(seg_org));
  heap_cells += ni;
  return size;
#ifdef scmptr
# undef scmptr
#endif
}
static void alloc_some_heap()
{
  CELLPTR ptr, *tmplims;
  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);
  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_cells)*sizeof(cell));
    if ((sizet)(EXPHEAP(heap_cells)*sizeof(cell)) != len) len = 0;
  }
  else len = HEAP_SEG_SIZE;
  while (len >= MIN_HEAP_SEG_SIZE) {
    SYSCALL(ptr = (CELLPTR) malloc(len););
    if (ptr) {
      init_heap_seg(ptr, len);
      return;
    }
    len /= 2;
  }
  wta(UNDEFINED, s_nogrow, s_heap);
}

smobfuns *smobs;
sizet numsmob;
long newsmob(smob)
     smobfuns *smob;
{
  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++;
  }
  ALLOW_INTS;
  if (!tmp) smoberr: wta(MAKINUM((long)numsmob), (char *)NALLOC, "newsmob");
  return tc7_smob + (numsmob-1)*256;
}
ptobfuns *ptobs;
sizet numptob;
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++;
  }
  ALLOW_INTS;
  if (!tmp) ptoberr: wta(MAKINUM((long)numptob), (char *)NALLOC, "newptob");
  return tc7_port + (numptob-1)*256;
}
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;
{
  return 0;
}
SCM equal0(ptr1, ptr2)
     SCM 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 */
void init_storage(stack_start_ptr, init_heap_size)
     STACKITEM *stack_start_ptr;
     long init_heap_size;
{
	sizet j = num_protects;
	/* 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_INT
	if (sizeof(int) >= sizeof(long))
	  fixconfig(remsg, "SHORT_INT", 1);
#else
	if (sizeof(int) < sizeof(long))
	  fixconfig(addmsg, "SHORT_INT", 1);
#endif
#ifdef CDR_DOUBLES
	if (sizeof(double) != sizeof(long))
	  fixconfig(remsg, "CDR_DOUBLES", 0);
#else
# ifdef SINGLES
	if (sizeof(float) != sizeof(long))
	  if (sizeof(double) == sizeof(long))
	    fixconfig(addmsg, "CDR_DOUBLES", 0);
	  else
	    fixconfig(remsg, "SINGLES", 0);
# endif
#endif
#ifdef BIGDIG
	if (2*BITSPERDIG/CHAR_BIT > sizeof(long))
	  fixconfig(remsg, "BIGDIG", 0);
# ifndef DIGSTOOBIG
	if (DIGSPERLONG*sizeof(BIGDIG) > sizeof(long))
	  fixconfig(addmsg, "DIGSTOOBIG", 0);
# endif
#endif
#ifdef STACK_GROWS_UP
	if (((STACKITEM *)&j - stack_start_ptr) < 0)
	  fixconfig(remsg, "STACK_GROWS_UP", 1);
#else
	if ((stack_start_ptr - (STACKITEM *)&j) < 0)
	  fixconfig(addmsg, "STACK_GROWS_UP", 1);
#endif
	j = HEAP_SEG_SIZE;
	if (HEAP_SEG_SIZE != j)
	  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;
	if ((init_heap_size != j) || !init_heap_seg((CELLPTR) malloc(j), j)) {
	  j = HEAP_SEG_SIZE;
	  if (!init_heap_seg((CELLPTR) malloc(j), j))
	    wta(MAKINUM(j), (char *)NALLOC, s_heap);
	}
	else expmem = 1;
	heap_org = CELL_UP(hplims[0]);
		/* hplims[0] can change. do not remove heap_org */

	NEWCELL(def_inp);
	CAR(def_inp) = (tc16_fport|OPN|RDNG);
	SETSTREAM(def_inp, stdin);
	NEWCELL(def_outp);
	CAR(def_outp) = (tc16_fport|OPN|WRTNG);
	SETSTREAM(def_outp, stdout);
	NEWCELL(def_errp);
	CAR(def_errp) = (tc16_fport|OPN|WRTNG);
	SETSTREAM(def_errp, stderr);
	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;
	listofnull = cons(EOL, EOL);
	undefineds = cons(UNDEFINED, EOL);
	CDR(undefineds) = undefineds;
	nullstr = makstr(0L);
	nullvect = make_vector(INUM0, UNDEFINED);
	/* NEWCELL(nullvect);
	   CAR(nullvect) = tc7_vector;
	   SETCHARS(nullvect, NULL); */
	symhash = make_vector((SCM)MAKINUM(symhash_dim), EOL);
	sysintern("most-positive-fixnum", (SCM)MAKINUM(MOST_POSITIVE_FIXNUM));
	sysintern("most-negative-fixnum", (SCM)MAKINUM(MOST_NEGATIVE_FIXNUM));
#ifdef BIGDIG
	sysintern("bignum-radix", MAKINUM(BIGRAD));
#endif
	/* flo0 is now setup in scl.c */
	/* Set up environment cache */
	scm_ecache_len = sizeof(ecache_v)/sizeof(cell);
	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 */
/* Scheme In One Defun, but in C this time.

 *			  COPYRIGHT (c) 1989 BY				    *
 *	  PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS.	    *
 *			   ALL RIGHTS RESERVED				    *

Permission to use, copy, modify, distribute and sell this software
and its documentation for any purpose and without fee is hereby
granted, provided that the above copyright notice appear in all copies
and that both that copyright notice and this permission notice appear
in supporting documentation, and that the name of Paradigm Associates
Inc not be used in advertising or publicity pertaining to distribution
of the software without specific, written prior permission.

PARADIGM DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL
PARADIGM BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
SOFTWARE.

gjc@paradigm.com

Paradigm Associates Inc		 Phone: 617-492-6079
29 Putnam Ave, Suite 6
Cambridge, MA 02138
*/
char s_cells[] = "cells";
SCM gc_for_newcell()
{
	SCM fl;
	int oints = ints_disabled; /* Temporary expedient */
	if (!oints) ints_disabled = 1;
	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);
	}
	++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(arg)
     SCM arg;
{
  DEFER_INTS;
  if UNBNDP(arg)
    igc("call", CONT(rootcont)->stkbse);
  else
    scm_egc();
  ALLOW_INTS;
  return UNSPECIFIED;
}
void igc(what, stackbase)
     char *what;
     STACKITEM *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 */
#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.  */
  mark_sym_values(symhash);
#endif
  egc_mark();
  if (stackbase) {
    FLUSH_REGISTER_WINDOWS;
    /* This assumes that all registers are saved into the jump_buf */
    setjump(save_regs_gc_mark);
    mark_locations((STACKITEM *) save_regs_gc_mark,
		   (sizet) (sizeof(STACKITEM) - 1 + sizeof save_regs_gc_mark) /
		   sizeof(STACKITEM));
    {
      /* stack_len is long rather than sizet in order to guarantee that
	 &stack_len is long aligned */
#ifdef STACK_GROWS_UP
# ifdef nosve
      long stack_len = (STACKITEM *)(&stack_len) - stackbase;
# else
      long stack_len = stack_size(stackbase);
# endif
      mark_locations(stackbase, (sizet)stack_len);
#else
# ifdef nosve
      long stack_len = stackbase - (STACKITEM *)(&stack_len);
# else
      long stack_len = stack_size(stackbase);
# endif
      mark_locations((stackbase - stack_len), (sizet)stack_len);
#endif
    }
  }
  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_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);
  }
}

static char s_not_free[] = "not freed";
void free_storage()
{
  DEFER_INTS;
  gc_start("free");
  ++errjmp_bad;
  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 */
  gc_sweep(0);
  rootcont = BOOL_F;
  while (hplim_ind) {		/* free heap segments */
    hplim_ind -= 2;
    {
      CELLPTR ptr = CELL_UP(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_cells, s_cells, 0); fflush(stderr);
    }}
  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"); */
  hplims = 0;
  /*  must_free((char *)smobs, numsmob * sizeof(smobfuns)); */
  free((char *)smobs);
  smobs = 0;
  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;
  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 */
      ) wta(ptr, "rogue pointer in ", s_heap);
  switch TYP7(ptr) {
  case tcs_cons_nimcar:
    if GCMARKP(ptr) break;
    SETGCMARK(ptr);
    if IMP(CDR(ptr)) {		/* IMP works even with a GC mark */
      ptr = CAR(ptr);
      goto gc_mark_nimp;
    }
    gc_mark(CAR(ptr));
    ptr = GCCDR(ptr);
    goto gc_mark_nimp;
  case tcs_cons_imcar:
  case tcs_cons_gloc:
    if GCMARKP(ptr) break;
    SETGCMARK(ptr);
    ptr = GCCDR(ptr);
    goto gc_mark_loop;
  case tcs_closures:
    if GCMARKP(ptr) break;
    SETGCMARK(ptr);
    if IMP(GCENV(ptr)) {
      ptr = CODE(ptr);
      goto gc_mark_nimp;
    }
    gc_mark(CODE(ptr));
    ptr = GCENV(ptr);
    goto gc_mark_nimp;
  case tc7_specfun:
    if GC8MARKP(ptr) break;
    SETGC8MARK(ptr);
#ifdef 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);
    if (i==0) break;
    while(--i>0) if NIMP(VELTS(ptr)[i]) gc_mark(VELTS(ptr)[i]);
    ptr = VELTS(ptr)[0];
    goto gc_mark_loop;
  case tc7_contin:
    if GC8MARKP(ptr) break;
    SETGC8MARK(ptr);
    mark_locations((STACKITEM *)VELTS(ptr),
		   (sizet)(LENGTH(ptr) +
			   (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:
    SETGC8MARK(ptr);
  case tcs_subrs:
    break;
  case tc7_port:
    i = PTOBNUM(ptr);
    if (!(i < numptob)) goto def;
    ptr = (ptobs[i].mark)(ptr);
    goto gc_mark_loop;
  case tc7_smob:
    if GC8MARKP(ptr) break;
    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;
      ptr = (smobs[i].mark)(ptr);
      goto gc_mark_loop;
    }
    break;
  default: def: wta(ptr, s_bad_type, "gc_mark");
  }
}

/* mark_locations() marks a location pointed to by x[0:n] only if
   `x[m]' is cell-aligned and points into a valid heap segment.  This
   code is duplicated by objunhash() in "sys.c" and scm_cell_p() in
   "rope.c", which means that changes to these routines must be
   coordinated. */

void mark_locations(x, n)
     STACKITEM x[];
     sizet n;
{
	register long m = n;
	register int i, j;
	register CELLPTR ptr;
	while(0 <= --m) if CELLP(*(SCM **)&x[m]) {
		ptr = (CELLPTR)SCM2PTR((*(SCM **)&x[m]));
		i = 0;
		j = hplim_ind;
		do {
			if PTR_GT(hplims[i++], ptr) break;
			if PTR_LE(hplims[--j], ptr) break;
			if ((i != j)
			    && PTR_LE(hplims[i++], ptr)
			    && PTR_GT(hplims[--j], ptr)) continue;
			/* if NFREEP(*(SCM **)&x[m]) */ gc_mark(*(SCM *)&x[m]);
			break;
		} while(i<j);
	}
}

static void gc_sweep(contin_bad)
     int contin_bad;
{
  register CELLPTR ptr;
#ifdef POINTERS_MUNGED
  register SCM scmptr;
#else
# define scmptr (SCM)ptr
#endif
  register SCM nfreelist = EOL;
  register long n = 0, m = 0;
  register sizet j, minc;
  sizet i = 0;
  sizet seg_cells;
  while (i<hplim_ind) {
    ptr = CELL_UP(hplims[i++]);
    seg_cells = CELL_DN(hplims[i++]) - ptr;
    for(j = seg_cells;j--;++ptr) {
#ifdef POINTERS_MUNGED
      scmptr = PTR2SCM(ptr);
#endif
      switch TYP7(scmptr) {
      case tcs_cons_imcar:
      case tcs_cons_nimcar:
      case tcs_cons_gloc:
      case tcs_closures:
	if GCMARKP(scmptr) goto cmrkcontinue;
	break;
      case tc7_specfun:
	if GC8MARKP(scmptr) goto c8mrkcontinue;
#ifdef CCLO
	if (tc16_cclo==GCTYP16(scmptr)) {
	  minc = (CCLO_LENGTH(scmptr)*sizeof(SCM));
	  goto freechars;
	}
#endif
	break;
      case tc7_vector:
	if GC8MARKP(scmptr) goto c8mrkcontinue;
	minc = (LENGTH(scmptr)*sizeof(SCM));
      freechars:
	m += minc;
	must_free(CHARS(scmptr), minc);
/*	SETCHARS(scmptr, 0);*/
	break;
      case tc7_bvect:
	if GC8MARKP(scmptr) goto c8mrkcontinue;
	minc = sizeof(long)*((HUGE_LENGTH(scmptr)+LONG_BIT-1)/LONG_BIT);
	goto freechars;
      case tc7_ivect:
      case tc7_uvect:
	if GC8MARKP(scmptr) goto c8mrkcontinue;
	minc = HUGE_LENGTH(scmptr)*sizeof(long);
	goto freechars;
      case tc7_fvect:
	if GC8MARKP(scmptr) goto c8mrkcontinue;
	minc = HUGE_LENGTH(scmptr)*sizeof(float);
	goto freechars;
      case tc7_dvect:
	if GC8MARKP(scmptr) goto c8mrkcontinue;
	minc = HUGE_LENGTH(scmptr)*sizeof(double);
	goto freechars;
      case tc7_cvect:
	if GC8MARKP(scmptr) goto c8mrkcontinue;
	minc = HUGE_LENGTH(scmptr)*2*sizeof(double);
	goto freechars;
      case tc7_string:
	if GC8MARKP(scmptr) goto c8mrkcontinue;
	minc = HUGE_LENGTH(scmptr)+1;
	goto freechars;
      case tc7_msymbol:
	if GC8MARKP(scmptr) goto c8mrkcontinue;
	minc = LENGTH(scmptr)+1;
	goto freechars;
      case tc7_contin:
	if GC8MARKP(scmptr) {
	  if (contin_bad && CONT(scmptr)->length) {
	    warn("uncollected ", (char *)0);
	    iprin1(scmptr, cur_errp, 1);
	    lputc('\n', cur_errp);
	    lfflush(cur_errp);
	  }
	  goto c8mrkcontinue;
	}
	minc = LENGTH(scmptr)*sizeof(STACKITEM) + sizeof(CONTINUATION);
 	m += minc;
	free_continuation(CONT(scmptr)); break; /* goto freechars; */
      case tc7_ssymbol:
	if GC8MARKP(scmptr) goto c8mrkcontinue;
	/* Do not free storage because tc7_ssymbol means scmptr's
           storage was not created by a call to malloc(). */
	break;
      case tcs_subrs:
	continue;
      case tc7_port:
	if GC8MARKP(scmptr) goto c8mrkcontinue;
	if OPENP(scmptr) {
	  int k = PTOBNUM(scmptr);
	  if (!(k < numptob)) goto sweeperr;
				/* Yes, I really do mean ptobs[k].free */
				/* rather than ftobs[k].close.  .close */
				/* is for explicit CLOSE-PORT by user */
	  (ptobs[k].free)(STREAM(scmptr));
	  gc_ports_collected++;
	  SETSTREAM(scmptr, 0);
	  CAR(scmptr) &= ~OPN;
	}
	break;
      case tc7_smob:
	switch GCTYP16(scmptr) {
	case tc_free_cell:
	  if GC8MARKP(scmptr) goto c8mrkcontinue;
	  break;
#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);
	  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);
	    goto freechars;
	  case REAL_PART>>16:
	  case IMAG_PART>>16:
	    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;
	    minc = (smobs[k].free)((CELLPTR)scmptr);
	  }
	}
	break;
      default: sweeperr: wta(scmptr, s_bad_type, "gc_sweep");
      }
      ++n;
      CAR(scmptr) = (SCM)tc_free_cell;
      CDR(scmptr) = nfreelist;
      nfreelist = scmptr;
      continue;
    c8mrkcontinue:
      CLRGC8MARK(scmptr);
      continue;
    cmrkcontinue:
      CLRGCMARK(scmptr);
    }
#ifdef GC_FREE_SEGMENTS
    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;
      i -= 2;			/* need to scan segment just moved. */
      nfreelist = freelist;
    }
    else
#endif /* ifdef GC_FREE_SEGMENTS */
	freelist = nfreelist;
    gc_cells_collected += n;
    n = 0;
  }
  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 void mark_syms(v)
     SCM v;
{
  SCM x, al;
  int k = LENGTH(v);
  while (k--)
    for (al = VELTS(v)[k]; NIMP(al); al = GCCDR(al)) {
      /* If this bucket has already been marked, then something is wrong.  */
      ASSERT(!GCMARKP(al), al, s_bad_type, s_gc_sym);
      x = CAR(al);
      SETGCMARK(al);		/* Do mark bucket list */
# 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));
    used:
      /* SETGCMARK(x) */;	/* Don't mark value cell.  */
      /* We used to mark the value cell, but value cells get returned
	 by calls to intern().  This caused a rare GC leak which only
	 showed up in large programs. */
    }
  SETGC8MARK(v);		/* Mark bucket vector.  */
}

/* mark_symhash marks the values of hash table V.  */
static void mark_sym_values(v)
     SCM v;
{
  SCM x, al;
  int k = LENGTH(v);
  /* SETGC8MARK(v); */		/* already set by mark_syms */
  while (k--)
    for (al = VELTS(v)[k]; NIMP(al); al = GCCDR(al)) {
      x = GCCDR(CAR(al));
      if IMP(x) continue;
      gc_mark(x);
    }
}

/* Splice any unused valueless symbols out of the hash buckets. */
static void sweep_symhash(v)
     SCM v;
{
  SCM al, x, *lloc;
  int k = LENGTH(v);
  while (k--) {
    lloc = &(VELTS(v)[k]);
    while NIMP(al = (*lloc & ~1L)) {
      x = CAR(al);
      if GC8MARKP(CAR(x)) {
	lloc = &(CDR(al));
	SETGCMARK(x);
      }
      else {
	*lloc = CDR(al);
	CLRGCMARK(al);		/* bucket pair to be collected by gc_sweep */
	CLRGCMARK(x);		/* value cell to be collected by gc_sweep */
	gc_syms_collected++;
      }
    }
    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;
}

