/* Scheme implementation intended for JACAL.
   Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995 Aubrey Jaffer.

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 1, 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 program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

The author can be reached at jaffer@ai.mit.edu or
Aubrey Jaffer, 84 Pleasant St., Wakefield MA 01880
*/


#include <ctype.h>
#include "scm.h"
#include "setjump.h"

#ifdef __STDC__
#include <stdarg.h>
#define var_start(x, y) va_start(x, y)
#else
#include <varargs.h>
#define var_start(x, y) va_start(x)
#endif

#ifdef HAVE_UNISTD_H
#include <unistd.h>
#else
char *ttyname P ((int fd));
char *tmpnam P ((char *s));
sizet fwrite ();
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));
#endif

extern int fclose();
extern size_t fwrite ();

#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 THINK_C
#ifndef ARM_ULIB
#include <sys/ioctl.h>
#endif
#endif
#endif
#endif
#endif
#endif
#endif
#endif


/* {Ports - in general}
 * 
 */

/* Array of open ports, required for reliable MOVE->FDES etc.  */
struct scm_port_table *scm_port_table;

int scm_port_table_size = 0;	/* Number of ports in scm_port_table.  */
int scm_port_table_room = 20;	/* Size of the array.  */

/* Add a port to the table.  Call with DEFER_INTS active.  */
void
scm_add_to_port_table (port)
     SCM port;
{
  if (scm_port_table_size == scm_port_table_room) {
    scm_port_table = (struct scm_port_table *)
      scm_must_realloc ((char *) scm_port_table,
			(long) (sizeof (struct scm_port_table)
			* scm_port_table_room),
			(long) (sizeof (struct scm_port_table)
			* scm_port_table_room * 2),
			"port list");
    scm_port_table_room *= 2;
  }
  scm_port_table[scm_port_table_size].port = port;
  scm_port_table[scm_port_table_size].revealed = 0;
  scm_port_table_size++;
}

/* Remove a port from the table.  Call with DEFER_INTS active.  */
void
scm_remove_from_port_table (port)
     SCM port;
{
  int i = 0;
  while (scm_port_table[i].port != port)
    {
      i++;
      /* Error if not found: too violent?  May occur in GC.  */
      if (i >= scm_port_table_size)
	scm_wta (port, "Port not in table", "scm_remove_from_port_table");
    }
  scm_port_table[i].port = scm_port_table[scm_port_table_size - 1].port;
  scm_port_table[i].revealed
    = scm_port_table[scm_port_table_size - 1].revealed;
  scm_port_table_size--;
}

#define DEBUG
#ifdef DEBUG
/* Undocumented functions for debugging.  */
/* Return the number of ports in the table.  */
static char scm_s_pt_size[] = "pt-size";
SCM
scm_pt_size ()
{
  return MAKINUM (scm_port_table_size);
}

/* Return the ith member of the port table.  */
static char scm_s_pt_member[] = "pt-member";
SCM
scm_pt_member (member)
     SCM member;
{
  int i;
  ASSERT (INUMP (member), member, ARG1, scm_s_pt_member);
  i = INUM (member);
  if (i < 0 || i >= scm_port_table_size)
    return BOOL_F;
  else
    return scm_port_table[i].port;
}
#endif

/* Close all ports except those listed.  Useful when creating new
 * processes.
 */
static char scm_s_cape[] = "close-all-ports-except";
SCM
scm_cape (ports)
     SCM ports;
{
  int i = 0;
  ASSERT (NIMP (ports) && CONSP (ports), ports, ARG1, scm_s_cape);
  DEFER_INTS;  
  while (i < scm_port_table_size)
    {
      SCM thisport = scm_port_table[i].port;
      int found = 0;
      SCM ports_ptr = ports;

      while (NNULLP (ports_ptr))
	{
	  SCM port = CAR (ports_ptr);
	  if (i == 0)
	    ASSERT (NIMP (port) && OPPORTP (port), port, ARG1, scm_s_cape);
	  if (port == thisport)
	    found = 1;
	  ports_ptr = CDR (ports_ptr);
	}
      if (found)
	i++;
      else
	/* i is not to be incremented here.  */
	scm_close_port (thisport);
    }
  ALLOW_INTS;
  return UNSPECIFIED;
}

/* Find a port in the table and return its revealed count.  Return -1
 * if the port isn't in the table (should not happen).  Also used by
 * the garbage collector.
 */
int
scm_revealed_count (port)
     SCM port;
{
  int i;

  for (i = 0; i < scm_port_table_size; i++)
    {
      if (scm_port_table[i].port == port)
	return scm_port_table[i].revealed;
    }
  return -1;
}

/* Return the revealed count for a port.  */
char scm_s_port_revealed[] = "port-revealed";
SCM
scm_port_revealed (port)
     SCM port;
{
  int result;

  ASSERT (NIMP (port) && PORTP (port), port, ARG1, scm_s_port_revealed);

  if ((result = scm_revealed_count (port)) == -1)
    return BOOL_F;
  else
    return MAKINUM (result);
}

/* Set the revealed count for a port.  */
char scm_s_set_port_revealed[] = "set-port-revealed!";
SCM
scm_set_port_revealed (port, rcount)
     SCM port;
     SCM rcount;
{
  int i;

  ASSERT (NIMP (port) && PORTP (port), port, ARG1, scm_s_set_port_revealed);
  ASSERT (INUMP (rcount), rcount, ARG2, scm_s_set_port_revealed);
  DEFER_INTS;
  for (i = 0; i < scm_port_table_size; i++)
    {
      if (scm_port_table[i].port == port) {
	scm_port_table[i].revealed = INUM (rcount);
	return BOOL_T;
      }
    }
  ALLOW_INTS;
  return BOOL_F;
}

/* FIXME  */
void
scm_setfileno (fs, fd)
     FILE *fs;
     int fd;
{
#ifdef FILE_FD_FIELD
  fs->FILE_FD_FIELD = fd;
#else
  Configure.in could not guess the name of the correct field in a FILE *.
  This function needs to be ported to your system.
  It should change the descriptor refered to by a stdio stream, and nothing
  else.
#endif
}

/* Move ports with the specified file descriptor to new descriptors,
 * reseting the revealed count to 0.
 * Should be called with DEFER_INTS active.
 */
void
scm_evict_ports (fd)
     int fd;
{
  int i;

  for (i = 0; i < scm_port_table_size; i++)
    {
      if (FPORTP (scm_port_table[i].port)
	  && fileno (STREAM (scm_port_table[i].port)) == fd)
	{
	  scm_setfileno (STREAM (scm_port_table[i].port), dup (fd));
	  scm_set_port_revealed (scm_port_table[i].port, MAKINUM (0));
	}
    }
}

/* Return a list of ports using a given file descriptor.  */
char scm_s_fdes_ports[] = "fdes->ports";
SCM
scm_fdes_ports (fd)
     SCM fd;
{
  SCM result = EOL;
  int int_fd;
  int i;
  
  ASSERT (INUMP (fd), fd, ARG1, scm_s_fdes_ports);
  int_fd = INUM (fd);

  DEFER_INTS;
  for (i = 0; i < scm_port_table_size; i++)
    {
      if (FPORTP (scm_port_table[i].port)
	  && fileno (STREAM (scm_port_table[i].port)) == int_fd)
	result = scm_cons (scm_port_table[i].port, result);
    }
  ALLOW_INTS;
  return result;
}    
 

/* scm_close_port
 * Call the close operation on a port object. 
 */
char scm_s_close_port[] = "close-port";

SCM
scm_close_port (port)
     SCM port;
{
  sizet i;
  ASSERT (NIMP (port) && PORTP (port), port, ARG1, scm_s_close_port);
  if (CLOSEDP (port))
    return UNSPECIFIED;
  i = PTOBNUM (port);
  DEFER_INTS;
  if (scm_ptobs[i].fclose)
    SYSCALL ((scm_ptobs[i].fclose) (STREAM (port)));
  scm_remove_from_port_table (port);
  CAR (port) &= ~OPN;
  ALLOW_INTS;
  return UNSPECIFIED;
}


static char s_input_portp[] = "input-port?";

SCM 
scm_input_portp (x)
     SCM x;
{
  if (IMP (x))
 return BOOL_F;
  return INPORTP (x) ? BOOL_T : BOOL_F;
}


static char s_output_portp[] = "output-port?";

SCM 
scm_output_portp (x)
     SCM x;
{
  if (IMP (x))
 return BOOL_F;
  return OUTPORTP (x) ? BOOL_T : BOOL_F;
}


void 
scm_prinport (exp, port, type)
     SCM exp;
     SCM port;
     char *type;
{
  scm_lputs ("#<", port);
  if (CLOSEDP (exp))
    scm_lputs ("closed-", port);
  else
    {
      if (RDNG & CAR (exp))
	scm_lputs ("input-", port);
      if (WRTNG & CAR (exp))
	scm_lputs ("output-", port);
    }
  scm_lputs (type, port);
  scm_lputc (' ', port);
#ifndef MSDOS
#ifndef __EMX__
#ifndef _DCC
#ifndef AMIGA
#ifndef THINK_C
  if (OPENP (exp) && tc16_fport == TYP16 (exp) && isatty (fileno (STREAM (exp))))
    scm_lputs (ttyname (fileno (STREAM (exp))), port);
  else
#endif
#endif
#endif
#endif
#endif
  if (OPFPORTP (exp))
    scm_intprint ((long) fileno (STREAM (exp)), 10, port);
  else
    scm_intprint (CDR (exp), 16, port);
  scm_lputc ('>', port);
}

#ifdef vms
static 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


/* {Ports - file ports}
 * 
 */

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

/* Return the flags that characterize a port based on the mode
 * string used to open a file for that port.
 *
 * See PORT FLAGS in scm.h
 */
long
scm_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_open_file
 * Return a new port open on a given file.
 *
 * The mode string must match the pattern: [rwa+]** which
 * is interpreted in the usual unix way.
 *
 * Return the new port.
 */

static char s_open_file[] = "open-file";

SCM
scm_mkfile (name, modes)
     char * name;
     char * modes;
{
  register SCM port;
  FILE *f;
  NEWCELL (port);
  DEFER_INTS;
  SYSCALL (f = fopen (name, modes));
  if (!f)
    {
      ALLOW_INTS;
      port = BOOL_F;
    }
  else
    {
      SETSTREAM (port, f);
      if (BUF0 & (CAR (port) = tc16_fport | scm_mode_bits (modes)))
	i_setbuf0 (port);
      scm_add_to_port_table (port);
      ALLOW_INTS;
    }
  return port;
}

SCM
scm_open_file (filename, modes)
     SCM filename;
     SCM modes;
{
  SCM port;
  ASSERT (NIMP (filename) && STRINGP (filename), filename, ARG1, s_open_file);
  ASSERT (NIMP (modes) && STRINGP (modes), modes, ARG2, s_open_file);
  port = scm_mkfile (CHARS (filename), CHARS (modes));
  /* Force the compiler to keep filename and modes alive:
   */
  if (port == BOOL_F)
    scm_cons (filename, modes);
  return port;
}

/* Return the mode flags from an open port.
 * Some modes such as "append" are only used when opening
 * a file and are not returned here.
 */
char scm_s_port_mode[] = "port-mode";
SCM scm_port_mode (port)
     SCM port;
{
  char modes[3] = "";
  ASSERT (NIMP (port) && OPPORTP (port), port, ARG1, scm_s_port_mode);  
  if (CAR (port) & RDNG) {
    if (CAR (port) & WRTNG)
      strcpy (modes, "r+");
    else
      strcpy (modes, "r");
  }
  else if (CAR (port) & WRTNG)
    strcpy (modes, "w");
  if (CAR (port) & BUF0)
    strcat (modes, "0");
  return scm_makfromstr (modes, strlen (modes), 0);
}


static int 
prinfport (exp, port, writing)
     SCM exp;
     SCM port;
     int writing;
{
  scm_prinport (exp, port, s_port_type);
  return !0;
}


static int
scm_fgetc (s)
     FILE * s;
{
  if (feof (s))
    return EOF;
  else
    return fgetc (s);
}

static scm_ptobfuns fptob =
{
  scm_mark0,
  fclose,
  prinfport,
  0,
  fputc,
  fputs,
  ffwrite,
  fflush,
  scm_fgetc,
  fclose
};


/* {Ports - string ports}
 * 
 */

static int 
prinstpt (exp, port, writing)
     SCM exp;
     SCM port;
     int writing;
{
  scm_prinport (exp, port, s_string);
  return !0;
}

static int 
stputc (c, p)
     int c;
     SCM p;
{
  sizet ind = INUM (CAR (p));
  if (ind >= LENGTH (CDR (p)))
    scm_resizuve (CDR (p), MAKINUM (ind + (ind >> 1)));
  CHARS (CDR (p))[ind] = c;
  CAR (p) = MAKINUM (ind + 1);
  return c;
}

static 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)))
    scm_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 CHARS (CDR (p))[ind];
}

SCM 
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 = scm_cons(pos, str);
  NEWCELL (z);
  DEFER_INTS;
  SETCHARS(z, str);
  CAR (z) = tc16_strport | modes;
  scm_add_to_port_table (z);
  ALLOW_INTS;
  return z;
}

static char s_cwos[] = "call-with-output-string";
static char s_cwis[] = "call-with-input-string";
SCM 
scm_cwos (proc)
     SCM proc;
{
  SCM p = scm_mkstrport(INUM0, scm_make_string(MAKINUM(30), SCM_UNDEFINED),
			OPN | WRTNG,
			s_cwos);
  scm_apply (proc, p, listofnull);
  return scm_resizuve (CDR (CDR (p)), CAR (CDR (p)));
}

SCM 
scm_cwis (str, proc)
     SCM str, proc;
{
  SCM p = scm_mkstrport(INUM0, str, OPN | RDNG, s_cwis);
  return scm_apply (proc, p, listofnull);
}

static int 
noop0 (stream)
     FILE *stream;
{
  return 0;
}

static scm_ptobfuns stptob =
{
  scm_markcdr,
  noop0,
  prinstpt,
  0,
  stputc,
  stputs,
  stwrite,
  noop0,
  stgetc,
  0
};


/* {Ports - soft ports}
 * 
 */


static int 
prinsfpt (exp, port, writing)
     SCM exp;
     SCM port;
     int writing;
{
  scm_prinport (exp, port, "soft");
  return !0;
}

/* sfputc sfwrite sfputs sfclose 
 * are called within a SYSCALL.  
 *
 * So we need to set errno to 0 before returning.  sfflush
 * 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;
{
  scm_apply (VELTS (p)[0], MAKICHR (c), listofnull);
  errno = 0;
  return c;
}

static sizet 
sfwrite (str, siz, num, p)
     sizet siz, num;
     char *str;
     SCM p;
{
  SCM sstr;
  sstr = scm_makfromstr (str, siz * num, 0);
  scm_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;
}

static int 
sfflush (stream)
     SCM stream;
{
  SCM f = VELTS (stream)[2];
  if (BOOL_F == f)
    return 0;
  f = scm_apply (f, EOL, EOL);
  errno = 0;
  return BOOL_F == f ? EOF : 0;
}

static int 
sfgetc (p)
     SCM p;
{
  SCM ans;
  ans = scm_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 = scm_apply (f, EOL, EOL);
  errno = 0;
  return BOOL_F == f ? EOF : 0;
}


static char s_mksfpt[] = "make-soft-port";

SCM 
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 | scm_mode_bits (CHARS (modes));
  SETSTREAM (z, pv);
  scm_add_to_port_table (z);
  ALLOW_INTS;
  return z;
}


static scm_ptobfuns sfptob =
{
  scm_markcdr,
  noop0,
  prinsfpt,
  0,
  sfputc,
  sfputs,
  sfwrite,
  sfflush,
  sfgetc,
  sfclose
};


/* {Pipe ports}
 */
scm_ptobfuns scm_pipob =
{
  scm_mark0,
  0, 				/* replaced by pclose in scm_init_ioext() */
  0, 				/* replaced by prinpipe in scm_init_ioext() */
  0,
  fputc,
  fputs,
  ffwrite,
  fflush,
  scm_fgetc,
  0
};				/* replaced by pclose in scm_init_ioext() */


/* {Files in general}
 */


#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 
scm_ltmpnam ()
{
  char name[L_tmpnam];
  SYSCALL (tmpnam (name););
  return scm_makfromstr (name, strlen (name), 0);
}

#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 
scm_ltmpnam ()
{
  SCM name;
  int temppos = TEMPLEN - 9;
  name = scm_makfromstr (template, (sizet) TEMPLEN, 0);
  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 
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;
}


/* {Initialization for types in general}
 */

/* scm_smobs scm_numsmob
 * implement a dynamicly resized array of smob records.
 * Indexes into this table are used when generating type
 * tags for smobjects (if you know a tag you can get an index and conversely).
 */
sizet scm_numsmob;
scm_smobfuns *scm_smobs;

long 
scm_newsmob (smob)
     scm_smobfuns *smob;
{
  char *tmp;
  if (255 <= scm_numsmob)
    goto smoberr;
  DEFER_INTS;
  SYSCALL (tmp = (char *) realloc ((char *) scm_smobs, (1 + scm_numsmob) * sizeof (scm_smobfuns)));
  if (tmp)
    {
      scm_smobs = (scm_smobfuns *) tmp;
      scm_smobs[scm_numsmob].mark = smob->mark;
      scm_smobs[scm_numsmob].free = smob->free;
      scm_smobs[scm_numsmob].print = smob->print;
      scm_smobs[scm_numsmob].equalp = smob->equalp;
      scm_numsmob++;
    }
  ALLOW_INTS;
  if (!tmp)
  smoberr:scm_wta (MAKINUM ((long) scm_numsmob), (char *) NALLOC, "newsmob");
  return tc7_smob + (scm_numsmob - 1) * 256;
}

/* scm_ptobs scm_numptob
 * implement a dynamicly resized array of ptob records.
 * Indexes into this table are used when generating type
 * tags for smobjects (if you know a tag you can get an index and conversely).
 */
scm_ptobfuns *scm_ptobs;
sizet scm_numptob;

long 
scm_newptob (ptob)
     scm_ptobfuns *ptob;
{
  char *tmp;
  if (255 <= scm_numptob)
    goto ptoberr;
  DEFER_INTS;
  SYSCALL (tmp = (char *) realloc ((char *) scm_ptobs, (1 + scm_numptob) * sizeof (scm_ptobfuns)));
  if (tmp)
    {
      scm_ptobs = (scm_ptobfuns *) tmp;
      scm_ptobs[scm_numptob].mark = ptob->mark;
      scm_ptobs[scm_numptob].free = ptob->free;
      scm_ptobs[scm_numptob].print = ptob->print;
      scm_ptobs[scm_numptob].equalp = ptob->equalp;
      scm_ptobs[scm_numptob].fputc = ptob->fputc;
      scm_ptobs[scm_numptob].fputs = ptob->fputs;
      scm_ptobs[scm_numptob].fwrite = ptob->fwrite;
      scm_ptobs[scm_numptob].fflush = ptob->fflush;
      scm_ptobs[scm_numptob].fgetc = ptob->fgetc;
      scm_ptobs[scm_numptob].fclose = ptob->fclose;
      scm_numptob++;
    }
  ALLOW_INTS;
  if (!tmp)
  ptoberr:scm_wta (MAKINUM ((long) scm_numptob), (char *) NALLOC, "newptob");
  return tc7_port + (scm_numptob - 1) * 256;
}



/* {Catch and Throw} 
 */
static int tc16_jmpbuffer;

#define JMPBUFP(O) (TYP16(O) == tc16_jmpbuffer)
#define JBACTIVE(O) (CAR (O) & (1L << 16L))
#define ACTIVATEJB(O)  (CAR (O) |= (1L << 16L))
#define DEACTIVATEJB(O)  (CAR (O) &= ~(1L << 16L))
#define JBJMPBUF(O) ((jmp_buf*)CDR (O) )


static int
printjb (exp, port, writing)
     SCM exp;
     SCM port;
     int writing;
{
  scm_lputs ("#<jmpbuffer ", port);
  scm_lputs (JBACTIVE(exp) ? "(active) " : "(inactive) ", port);
  scm_intprint(CDR(exp), 16, port);
  scm_lputc ('>', port);
  return 1 ;
}

static scm_smobfuns jbsmob = {scm_mark0, scm_free0, printjb, 0};

static SCM
make_jmpbuf ()
{
  SCM answer;
  NEWCELL (answer);
  DEFER_INTS;
  {
    CAR(answer) = tc16_jmpbuffer;
    JBJMPBUF(answer) = (jmp_buf *)0;
    DEACTIVATEJB(answer);
  }
  ALLOW_INTS;
  return answer;
}

static char s_catchwind[] = "catch";

SCM
scm_catchwind (tag, thunk, handler)
     SCM tag;
     SCM thunk;
     SCM handler;
{
  jmp_buf buf;
  SCM jmpbuf;
  SCM answer;

  ASSERT ((tag == BOOL_F) || (NIMP(tag) && SYMBOLP(tag)) || (tag == BOOL_T),
	  tag, ARG1, s_catchwind);
  jmpbuf = make_jmpbuf ();
  answer = EOL;
  dynwinds = scm_acons (tag, jmpbuf, dynwinds);
  JBJMPBUF(jmpbuf) = &buf;
  if (setjmp (buf))
    {
      SCM throw_args;
      DEFER_INTS;
      DEACTIVATEJB (jmpbuf);
      dynwinds = CDR (dynwinds);
      ALLOW_INTS;
      throw_args = scm_throwval;
      scm_throwval = EOL;
      answer = scm_apply (handler, scm_cons (tag, throw_args), EOL);
    }
  else
    {
      ACTIVATEJB (jmpbuf);
      answer = scm_apply (thunk,
			  ((tag == EOL) ? scm_cons (jmpbuf, EOL) : EOL),
			  EOL);
      DEFER_INTS;
      DEACTIVATEJB (jmpbuf);
      dynwinds = CDR (dynwinds);
      ALLOW_INTS;
    }
  return answer;
}


char scm_s_throw[] = "throw";
static SCM bad_throw_vcell;
SCM
_scm_throw (key, args, noreturn)
     SCM key;
     SCM args;
     int noreturn;
{
  SCM jmpbuf;
  if (NIMP (key) && JMPBUFP (key))
    {
      jmpbuf = key;
      if (noreturn)
	{
	  ASSERT (JBACTIVE (jmpbuf), jmpbuf,
		  "throw to dynamicly inactive catch",
		  scm_s_throw);
	}
      else if (!JBACTIVE (jmpbuf))
	return UNSPECIFIED;
    }
  else
    {
      SCM dynpair;
      if (noreturn)
	{
	  ASSERT (NIMP (key) && SYMBOLP (key), key, ARG1, scm_s_throw);
	}
      else if (!(NIMP (key) && SYMBOLP (key)))
	return UNSPECIFIED;

      dynpair = scm_assoc (key, dynwinds);

      if (dynpair == BOOL_F)
	dynpair = scm_assoc (BOOL_T, dynwinds);

      if ((dynpair == BOOL_F)
	  && (BOOL_T == scm_procedurep (CDR (bad_throw_vcell))))
	{
	  SCM answer;
	  answer = scm_apply (CDR (bad_throw_vcell), scm_cons (key, args), EOL);
	}
      
      if (noreturn)
	{
	  ASSERT (dynpair != BOOL_F,
		  scm_cons (key, args),
		  "missing CATCH", scm_s_throw);
	}
      else if (dynpair == BOOL_F)
	return UNSPECIFIED;

      jmpbuf = CDR (dynpair);
    }
  scm_throwval = args;
  longjmp (*JBJMPBUF (jmpbuf), 1);
}



SCM
scm_throw (key, args)
     SCM key;
     SCM args;
{
  _scm_throw (key, args, 1);
  return BOOL_F;  /* never really returns */
}


char scm_s_throw_or_retry[] = "throw-or-retry";
SCM
scm_throw_or_retry (key, args, noreturn)
     SCM key;
     SCM args;
{
  _scm_throw(key, args, 2);
}


static char s_dynamic_root[] = "dynamic-root";

SCM
scm_dynamic_root ()
{
  return scm_ulong2num (SEQ (rootcont));
}



/* {Initialization for i/o types, float, bignum, the type of free cells}
 */

static scm_smobfuns freecell =
{
  scm_mark0,
  scm_free0,
  0,
  0
};

static scm_smobfuns flob =
{
  scm_mark0,
  /*flofree*/ 0,
  scm_floprint,
  scm_floequal
};

static scm_smobfuns bigob =
{
  scm_mark0,
  /*bigfree*/ 0,
  scm_bigprint,
  scm_bigequal
};

void (**scm_finals) () = 0;
sizet scm_num_finals = 0;

void 
scm_init_types ()
{
  scm_numptob = 0;
  scm_ptobs = (scm_ptobfuns *) malloc (4 * sizeof (scm_ptobfuns));

  /* WARNING: These scm_newptob calls must be done in this order */
  /* tc16_fport = */ scm_newptob (&fptob);
  /* tc16_pipe = */ scm_newptob (&scm_pipob);
  /* tc16_strport = */ scm_newptob (&stptob);
  /* tc16_sfport = */ scm_newptob (&sfptob);

  scm_numsmob = 0;
  scm_smobs = (scm_smobfuns *) malloc (7 * sizeof (scm_smobfuns));

  /* WARNING: These scm_newsmob calls must be done in this order */
  scm_newsmob (&freecell);
  scm_newsmob (&flob);
  scm_newsmob (&bigob);
  scm_newsmob (&bigob);

  tc16_jmpbuffer = scm_newsmob (&jbsmob);

  scm_finals = (void (**)()) malloc (2 * sizeof (scm_finals[0]));
  scm_num_finals = 0;
}

static char s_final[] = "final";

void 
scm_add_final (final)
     void (*final) ();
{
  DEFER_INTS;
  scm_finals = ((void (**)())
		scm_must_realloc
		((char *) scm_finals,
		 1L * (scm_num_finals) * sizeof (scm_finals[0]),
		 (1L + scm_num_finals) * sizeof (scm_finals[0]),
		 s_final));
  scm_finals[scm_num_finals++] = final;
  ALLOW_INTS;
  return;
}


/* {Dynamic wind}
 */

SCM 
scm_dynwind (thunk1, thunk2, thunk3)
     SCM thunk1, thunk2, thunk3;
{
  SCM ans;
  scm_apply (thunk1, EOL, EOL);
  dynwinds = scm_acons (thunk1, thunk3, dynwinds);
  ans = scm_apply (thunk2, EOL, EOL);
  dynwinds = CDR (dynwinds);
  scm_apply (thunk3, EOL, EOL);
  return ans;
}

void 
scm_dowinds (to, delta)
     SCM to;
     long delta;
{
 tail:
  if (dynwinds == to);
  else if (0 > delta)
    {
      SCM wind_key;
      scm_dowinds (CDR (to), 1 + delta);
      wind_key = CAR (CAR (to));
      if (!(NIMP (wind_key) && SYMBOLP (wind_key)) && (wind_key != BOOL_F))
	scm_apply (wind_key, EOL, EOL);
      dynwinds = to;
    }
  else
    {
      SCM from;
      SCM wind_key;
      from = CDR (CAR (dynwinds));
      wind_key = CAR (CAR (dynwinds));
      dynwinds = CDR (dynwinds);
      if (!(NIMP (wind_key) && SYMBOLP (wind_key)) && (wind_key != BOOL_F))
	scm_apply (from, EOL, EOL);
      delta--;
      goto tail;		/* scm_dowinds(to, delta-1); */
    }
}


/* {Initialization for i/o and gc procedures.}
 */

char scm_s_obunhash[] = "object-unhash";
static scm_iproc subr0s[] =
{
  {"gc", scm_gc},
  {"tmpnam", scm_ltmpnam},
  {s_dynamic_root, scm_dynamic_root},
#ifdef DEBUG
  {scm_s_pt_size, scm_pt_size},
#endif
  {0, 0}
};

static scm_iproc subr1s[] =
{
  {scm_s_cape, scm_cape},
#ifdef DEBUG
  {scm_s_pt_member, scm_pt_member},
#endif
  {s_input_portp, scm_input_portp},
  {s_output_portp, scm_output_portp},
  {scm_s_close_port, scm_close_port},
  {scm_s_port_mode, scm_port_mode},
  {scm_s_port_revealed, scm_port_revealed},
  {scm_s_fdes_ports, scm_fdes_ports},
  {"eof-object?", scm_eof_objectp},
  {s_cwos, scm_cwos},
  {s_del_fil, scm_del_fil},
  {0, 0}
};

static scm_iproc subr2s[] =
{
  {scm_s_set_port_revealed, scm_set_port_revealed},
  {s_open_file, scm_open_file},
  {s_cwis, scm_cwis},
  {s_mksfpt, scm_mksfpt},
  {0, 0}
};

void 
scm_init_io ()
{
  scm_make_subr ("dynamic-wind", tc7_subr_3, scm_dynwind);
  scm_make_subr (s_catchwind, tc7_subr_3, scm_catchwind);
  /* Throw is initialized with the gsubr package. */
  scm_init_iprocs (subr0s, tc7_subr_0);
  scm_init_iprocs (subr1s, tc7_subr_1);
  scm_init_iprocs (subr2s, tc7_subr_2);
#ifndef CHEAP_CONTINUATIONS
  scm_add_feature ("full-continuation");
#endif
}


/* {Front end to malloc}
 *
 * scm_must_malloc, scm_must_realloc, scm_must_free
 *
 * These functions provide services comperable to malloc, realloc, and
 * free.  They are for allocating malloced parts of scheme objects.
 * The primary purpose of the front end is to impose calls to gc.
 */

/* scm_mtrigger
 * is the number of bytes of must_malloc allocation needed to trigger gc.
 */
long scm_mtrigger;



/* scm_grew_lim
 * is called whenever the must_malloc limit that triggers garbage collection
 * is raised.  The limit is raised if a garbage collection followed
 * by a subsequent allocation fails to reduce allocated storage below
 * the limit.
 */
void 
scm_grew_lim (nm)
     long nm;
{
  ALLOW_INTS;
  scm_growth_mon (s_limit, nm, "bytes");
  DEFER_INTS;
}

/* scm_must_malloc
 * Return newly malloced storage or throw an error.
 *
 * The parameter WHAT is a string for error reporting.
 * If the threshold scm_mtrigger will be passed by this 
 * allocation, or if the first call to malloc fails,
 * garbage collect -- on the presumption that some objects
 * using malloced storage may be collected.
 *
 * The limit scm_mtrigger may be raised by this allocation.
 */
char *
scm_must_malloc (len, what)
     long len;
     char *what;
{
  char *ptr;
  sizet size = len;
  long nm = scm_mallocated + size;
  if (len != size)
  malerr:
    scm_wta (MAKINUM (len), (char *) NALLOC, what);
  if ((nm <= scm_mtrigger))
    {
      SYSCALL (ptr = (char *) malloc (size));
      if (NULL != ptr)
	{
	  scm_mallocated = nm;
	  return ptr;
	}
    }
  scm_igc (what);
  nm = scm_mallocated + size;
  if (nm > scm_mtrigger)
    scm_grew_lim (nm + nm / 2);	/* must do before malloc */
  SYSCALL (ptr = (char *) malloc (size));
  if (NULL != ptr)
    {
      scm_mallocated = nm;
      if (nm > scm_mtrigger)
	scm_mtrigger = nm + nm / 2;
      return ptr;
    }
  goto malerr;
}


/* scm_must_realloc
 * is similar to scm_must_malloc.
 */
char *
scm_must_realloc (where, olen, len, what)
     char *where;
     long olen, len;
     char *what;
{
  char *ptr;
  sizet size = len;
  long nm = scm_mallocated + size - olen;
  if (len != size)
  ralerr:
    scm_wta (MAKINUM (len), (char *) NALLOC, what);
  if ((nm <= scm_mtrigger))
    {
      SYSCALL (ptr = (char *) realloc (where, size));
      if (NULL != ptr)
	{
	  scm_mallocated = nm;
	  return ptr;
	}
    }
  scm_igc (what);
  nm = scm_mallocated + size - olen;
  if (nm > scm_mtrigger)
    scm_grew_lim (nm + nm / 2);	/* must do before realloc */
  SYSCALL (ptr = (char *) realloc (where, size));
  if (NULL != ptr)
    {
      scm_mallocated = nm;
      if (nm > scm_mtrigger)
	scm_mtrigger = nm + nm / 2;
      return ptr;
    }
  goto ralerr;
}

/* scm_must_free
 * is for releasing memory from scm_must_realloc and scm_must_malloc.
 */
void 
scm_must_free (obj)
     char *obj;
{
  if (obj)
    free (obj);
  else
    scm_wta (INUM0, "already free", "");
}


/* {Heap Segments}
 *
 * Each heap segment is an array of objects of a particular size.
 * Every segment has an associated (possibly shared) freelist.
 * A table of segment records is kept that records the upper and
 * lower extents of the segment;  this is used during the conservative
 * phase of gc to identify probably gc roots (because they point
 * into valid segments at reasonable offsets).
 */

/* scm_expmem
 * is true if the first segment was smaller than INIT_HEAP_SEG.
 * If scm_expmem is set to one, subsequent segment allocations will
 * allocate segments of size EXPHEAP(scm_heap_size).
 */
int scm_expmem = 0;

/* scm_heap_org
 * is the lowest base address of any heap segment.
 */
CELLPTR scm_heap_org;

struct heap_seg_data * scm_heap_table = 0;
int scm_n_heap_segs = 0;

/* scm_heap_size
 * is the total number of cells in heap segments.
 */
long scm_heap_size = 0;

/* init_heap_seg
 * initializes a new heap segment and return the number of objects it contains.
 *
 * The segment origin, segment size in bytes, and the span of objects
 * in cells are input parameters.  The freelist is both input and output.
 *
 * This function presume that the scm_heap_table has already been expanded
 * to accomodate a new segment record.
 */

#define PTR_GT(x, y) PTR_LT(y, x)
#define PTR_LE(x, y) (!PTR_GT(x, y))
#define PTR_GE(x, y) (!PTR_LT(x, y))

static sizet 
init_heap_seg (seg_org, size, ncells, freelistp)
     CELLPTR seg_org;
     sizet size;
     int ncells;
     SCM *freelistp;
{
  register CELLPTR ptr;
#ifdef POINTERS_MUNGED
  register SCM scmptr;
#else
#define scmptr ptr
#endif
  CELLPTR seg_end;
  sizet new_seg_index;
  sizet n_new_objects;
  
  if (seg_org == NULL)
    return 0;

  ptr = seg_org;

  /* Compute the ceiling on valid object pointers w/in this segment. 
   */
  seg_end = CELL_DN ((char *) ptr + size);

  /* Find the right place and insert the segment record. 
   *
   */
  for (new_seg_index = 0;
       (   (new_seg_index < scm_n_heap_segs)
	&& PTR_LE (scm_heap_table[new_seg_index].bounds[0], seg_org));
       new_seg_index++)
    ;

  {
    int i;
    for (i = scm_n_heap_segs; i > new_seg_index; --i)
      scm_heap_table[i] = scm_heap_table[i - 1];
  }
  
  ++scm_n_heap_segs;

  scm_heap_table[new_seg_index].valid = 0;
  scm_heap_table[new_seg_index].ncells = ncells;
  scm_heap_table[new_seg_index].freelistp = freelistp;
  scm_heap_table[new_seg_index].bounds[0] = (CELLPTR)ptr;
  scm_heap_table[new_seg_index].bounds[1] = (CELLPTR)seg_end;


  /* Compute the least valid object pointer w/in this segment 
   */
  ptr = CELL_UP (ptr);


  n_new_objects = seg_end - ptr;

  /* Prepend objects in this segment to the freelist. 
   */
  while (ptr < seg_end)
    {
#ifdef POINTERS_MUNGED
      scmptr = PTR2SCM (ptr);
#endif
      CAR (scmptr) = (SCM) tc_free_cell;
      CDR (scmptr) = PTR2SCM (ptr + ncells);
      ptr += ncells;
    }

  ptr -= ncells;

  /* Patch up the last freelist pointer in the segment
   * to join it to the input freelist.
   */
  CDR (PTR2SCM (ptr)) = *freelistp;
  *freelistp = PTR2SCM (CELL_UP (seg_org));

  scm_heap_size += (ncells * n_new_objects);
  return size;
#ifdef scmptr
#undef scmptr
#endif
}


static char scm_s_nogrow[] = "could not grow";
char scm_s_heap[] = "heap";
static char scm_s_hplims[] = "hplims";

static void 
alloc_some_heap (ncells, freelistp)
     int ncells;
     SCM * freelistp;
{
  struct heap_seg_data * tmptable;
  CELLPTR ptr;
  sizet len;

  /* Critical code sections (such as the garbage collector)
   * aren't supposed to add heap segments.
   */
  if (scm_errjmp_bad)
    scm_wta (SCM_UNDEFINED, "need larger initial", scm_s_heap);

  /* Expand the heap tables to have room for the new segment.
   * Do not yet increment scm_n_heap_segs -- that is done by init_heap_seg
   * only if the allocation of the segment itself succeeds.
   */
  len = (1 + scm_n_heap_segs) * sizeof (struct heap_seg_data);

  SYSCALL (tmptable = ((struct heap_seg_data *)
		       realloc ((char *)scm_heap_table, len)));
  if (!tmptable)
    scm_wta (SCM_UNDEFINED, scm_s_nogrow, scm_s_hplims);
  else
    scm_heap_table = tmptable;


  /* Pick a size for the new heap segment.
   * The rule for picking the size of a segment is explained in 
   * (for some reason) setjump.h (c.f. {heap parameters}).
   */
  if (scm_expmem)
    {
      len = (sizet) (EXPHEAP (scm_heap_size) * sizeof (scm_cell));
      if ((sizet) (EXPHEAP (scm_heap_size) * sizeof (scm_cell)) != len)
	len = 0;
    }
  else
    len = HEAP_SEG_SIZE;

  {
    sizet smallest;

    smallest = (ncells * sizeof (scm_cell));
    if (len < smallest)
      len = (ncells * sizeof (scm_cell));

    /* Allocate with decaying ambition. */
    while ((len >= MIN_HEAP_SEG_SIZE)
	   && (len >= smallest))
      {
	SYSCALL (ptr = (CELLPTR) malloc (len));
	if (ptr)
	  {
	    init_heap_seg (ptr, len, ncells, freelistp);
	    return;
	  }
	len /= 2;
      }
  }

  scm_wta (SCM_UNDEFINED, scm_s_nogrow, scm_s_heap);
}



/* {cons pair allocation}
 */

/* scm_freelist
 * is the head of freelist of cons pairs.
 */
SCM scm_freelist = EOL;

/* scm_gc_for_newcell
 *
 * Still resides below under the PARADIGM ASSOCIATES copyright.
 */



void
scm_permenant_object (obj)
     SCM obj;
{
  permobjs = scm_cons (obj, permobjs);
}



/* {Object allocation}
 */

/* scm_moderate_freelists
 * is a table of freelists for object sizes less than SCM_MODERATE.
 */
#ifndef SCM_MODERATE
#define SCM_MODERATE 256
#endif

static SCM scm_moderate_freelists[SCM_MODERATE] = { (SCM)EOL };

/* scm_large_objects
 * a circular, doubly linked list of large objects.
 */
static scm_cell scm_large_objects
= { (SCM)&scm_large_objects, (SCM)&scm_large_objects };

struct large_obj_header
{
  scm_cell link;
  int size;
};

SCM
scm_alloc_large (ncells, reason)
     int ncells;
     char * reason;
{
  int bytes;
  struct large_obj_header * mem;
  SCM answer;

  bytes = (  (sizeof (scm_cell) * ncells)
	   + sizeof(struct large_obj_header));
  mem = (struct large_obj_header *)scm_must_malloc (bytes, "large reason");
  answer = (SCM)(mem + 1);

  DEFER_INTS;
  CAR(answer) = (SCM)tc_free_cell;
  CDR(answer) = (SCM)EOL;
  ALLOW_INTS;

  {
    int x;
    for (x = 0; x < ncells; ++x)
      ((SCM *)answer)[x] = BOOL_F;
  }

  mem->size = bytes;

  mem->link.car = scm_large_objects.car;
  mem->link.cdr = (SCM)&scm_large_objects;
  CDR(mem->link.car) = (SCM)&(mem->link);
  scm_large_objects.car = (SCM)&(mem->link);

  return answer;
}

static int
free_large (obj)
     SCM obj;
{
  struct large_obj_header * mem;
  struct scm_large_object_type * type;
  mem = (struct large_obj_header *)obj;
  mem -= 1;
  CDR(mem->link.car) = mem->link.cdr;
  CAR(mem->link.cdr) = mem->link.car;
  {
    int bytes;
    bytes = mem->size;
    scm_must_free ((char *)mem);
    return bytes;
  }
}

/* {Malloc-like allocation for Scheme objects of aribitrary size}
 * These can not be resized.
 */

char scm_s_cells[] = "cells";
static void
gc_for_alloc (ncells, freelistp)
     int ncells;
     SCM * freelistp;
{
  REDEFER_INTS;
  scm_igc (scm_s_cells);
  REALLOW_INTS;
  if ((scm_gc_cells_collected < MIN_GC_YIELD) || IMP (*freelistp))
    {
      REDEFER_INTS;
      alloc_some_heap (ncells, freelistp);
      REALLOW_INTS;
      if (!scm_ints_disabled) /* !!! */
	{
          scm_growth_mon ("number of heaps", 
			  (long) scm_n_heap_segs, 
			  "segments");
	  scm_growth_mon (scm_s_heap, scm_heap_size, scm_s_cells);
	}
    }
}

SCM
scm_alloc_obj (ncells, reason)
     SCM ncells;
     char * reason;
{
  int bytes;
  
  if (ncells > SCM_MODERATE)
    return scm_alloc_large (ncells, reason);
  else
    {
      SCM answer;
      answer = scm_moderate_freelists[ncells];
      if (answer == EOL)
	gc_for_alloc (ncells, &scm_moderate_freelists[ncells]);
      answer = scm_moderate_freelists[ncells];
      scm_moderate_freelists[ncells] = CDR (scm_moderate_freelists[ncells]);
    }
}


/* {Symbols}
 */

unsigned long 
scm_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) (scm_downcase[str[h % len]]))) % n;
      return h;
    }
  else
    {
      sizet i = len;
      unsigned long h = 0;
      while (i)
	h = ((h << 8) + ((unsigned) (scm_downcase[str[--i]]))) % n;
      return h;
    }
}

int scm_symhash_dim = NUM_HASH_BUCKETS;


/* scm_sym2vcell
 * looks up the symbol in the symhash table. 
 */
SCM 
scm_sym2vcell (sym, thunk, definep)
     SCM sym;
     SCM thunk;
     SCM definep;
{
  if (NIMP(thunk))
    {
      SCM var = scm_apply (thunk, sym, scm_cons(definep, listofnull));

      if (var == BOOL_F)
	return BOOL_F;
      else
	{
	  if (IMP(var) || !VARIABLEP (var))
	    scm_wta (sym, "strangely interned symbol? ", "");
	  return VARVCELL (var);
	}
    }
  else
    {
      SCM lsym, z;
      sizet scm_hash = scm_strhash (UCHARS (sym), (sizet) LENGTH (sym),
				    (unsigned long) scm_symhash_dim);
      for (lsym = VELTS (symhash)[scm_hash]; NIMP (lsym); lsym = CDR (lsym))
	{
	  z = CAR (lsym);
	  if (CAR (z) == sym)
	    return z;
	}
    }
 uninterned:
  scm_wta (sym, "uninterned symbol? ", "");
}

/* scm_sym2ovcell
 * looks up the symbol in an arbitrary obarray (defaulting to symhash).
 */
SCM 
scm_sym2ovcell_soft (sym, obarray)
     SCM sym;
     SCM obarray;
{
  SCM lsym, z;
  sizet scm_hash;

  scm_hash = scm_strhash (UCHARS (sym),
			  (sizet) LENGTH (sym),
			  LENGTH (obarray));
  for (lsym = VELTS (obarray)[scm_hash];
       NIMP (lsym);
       lsym = CDR (lsym))
    {
      z = CAR (lsym);
      if (CAR (z) == sym)
	return z;
    }
  return BOOL_F;
}

SCM 
scm_sym2ovcell (sym, obarray)
     SCM sym;
     SCM obarray;
{
  SCM answer;
  answer = scm_sym2ovcell_soft (sym, obarray);
  if (answer != BOOL_F)
    return answer;
  scm_wta (sym, "uninterned symbol? ", "");
}

SCM 

scm_intern_obarray_soft (name, len, obarray, softness)
     char *name;
     sizet len;
     SCM obarray;
     int softness;
{
  SCM lsym;
  SCM z;
  register sizet i;
  register unsigned char *tmp;
  sizet scm_hash;

  i = len;
  tmp = (unsigned char *) name;

  if (obarray == BOOL_F)
    {
      scm_hash = scm_strhash (tmp, i, 1019);
      goto uninterned_symbol;
    }

  scm_hash = scm_strhash (tmp, i, LENGTH(obarray));

  if (softness == -1)
    goto mustintern_symbol;

  for (lsym = VELTS (obarray)[scm_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:;
    }

 uninterned_symbol:
  if (softness)
    return BOOL_F;

 mustintern_symbol:
  lsym = scm_makfromstr (name, len, SYMBOL_SLOTS);
  DEFER_INTS;
  SETLENGTH (lsym, (long) len, tc7_msymbol);
  SYMBOL_HASH (lsym) = scm_hash;
  ALLOW_INTS;
  if (obarray == BOOL_F)
    {
      SCM answer;
      NEWCELL (answer);
      DEFER_INTS;
      CAR (answer) = lsym;
      CDR (answer) = SCM_UNDEFINED;
      ALLOW_INTS;
      return answer;
    }
  else
    return CAR (VELTS (obarray)[scm_hash] =
		scm_acons (lsym, SCM_UNDEFINED, VELTS (obarray)[scm_hash]));
}

SCM 

scm_intern_obarray (name, len, obarray)
     char *name;
     sizet len;
     SCM obarray;
{
  return scm_intern_obarray_soft (name, len, obarray, 0);
}


SCM 
scm_intern (name, len)
     char *name;
     sizet len;
{
  return scm_intern_obarray (name, len, symhash);
}

SCM
scm_intern0 (name)
     char * name;
{
  return scm_intern (name, strlen (name));
}


SCM 
scm_sysintern (name, val)
     char *name;
     SCM val;
{
  SCM easy_answer;
  easy_answer = scm_intern_obarray_soft (name, strlen (name), symhash, 1);
  if (NIMP (easy_answer))
    {
      CDR (easy_answer) = val;
      return easy_answer;
    }
  else
    {
      SCM lsym;
      sizet len = strlen (name);
      register unsigned char *tmp = (unsigned char *) name;
      sizet scm_hash = scm_strhash (tmp, len, (unsigned long) scm_symhash_dim);
      NEWCELL (lsym);
      SETLENGTH (lsym, (long) len, tc7_ssymbol);
      SETCHARS (lsym, name);
      lsym = scm_cons (lsym, val);
      VELTS (symhash)[scm_hash] = scm_cons (lsym, VELTS (symhash)[scm_hash]);
      return lsym;
    }
}



/* {Pairs}
 */

SCM 
scm_cons (x, y)
     SCM x, y;
{
  register SCM z;
  NEWCELL (z);
  CAR (z) = x;
  CDR (z) = y;
  return z;
}

#ifdef __STDC__
SCM
scm_listify (SCM elt, ...)
#else
SCM
scm_listify (elt, va_alist)
     SCM elt;
     va_dcl

#endif
{
  va_list foo;
  SCM answer;
  SCM *pos;

  var_start (foo, elt);
  answer = EOL;
  pos = &answer;
  while (elt != SCM_UNDEFINED)
    {
      *pos = scm_cons (elt, EOL);
      pos = &CDR (*pos);
      elt = va_arg (foo, SCM);
    }
  return answer;
}
     

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


/* {Strings}
 */

SCM 
scm_makstr (len, slots)
     long len;
     int slots;
{
  SCM s;
  SCM * mem;
  NEWCELL (s);
  --slots;
  REDEFER_INTS;
  mem = (SCM *)scm_must_malloc (sizeof (SCM) * (slots + 1) + len + 1,
				s_string);
  if (slots >= 0)
    {
      int x;
      mem[slots] = (SCM)mem;
      for (x = 0; x < slots; ++x)
	mem[x] = BOOL_F;
    }
  SETCHARS (s, (char *)(mem + slots + 1));
  SETLENGTH (s, len, tc7_string);
  REALLOW_INTS;
  CHARS (s)[len] = 0;
  return s;
}

/* converts C scm_array of strings to SCM scm_list of strings. */
/* If argc < 0, a null terminated scm_array is assumed. */
SCM 
makfromstrs (argc, argv)
     int argc;
     char **argv;
{
  int i = argc;
  SCM lst = EOL;
  if (0 > i)
    for (i = 0; argv[i]; i++);
  while (i--)
    lst = scm_cons (scm_makfromstr (argv[i], (sizet) strlen (argv[i]), 0), lst);
  return lst;
}

SCM
scm_take0str (it)
     char * it;
{
  SCM answer;
  NEWCELL (answer);
  DEFER_INTS;
  SETLENGTH (answer, strlen (it), tc7_string);
  CHARS (answer) = it;
  ALLOW_INTS;
  return answer;
}

SCM 
scm_makfromstr (src, len, slots)
     char *src;
     sizet len;
     int slots;
{
  SCM s;
  register char *dst;
  s = scm_makstr ((long) len, slots);
  dst = CHARS (s);
  while (len--)
    *dst++ = *src++;
  return s;
}


SCM 
makfrom0str (src)
     char *src;
{
  if (!src) return BOOL_F;
  return scm_makfromstr (src, (sizet) strlen (src), 0);
}

SCM 
makfrom0str_opt (src)
     char *src;
{
  return makfrom0str (src);
}


/* {Procedures}
 */

SCM 
scm_make_subr (name, type, fcn)
     char *name;
     int type;
     SCM (*fcn) ();
{
  SCM symcell = scm_sysintern (name, SCM_UNDEFINED);
  long tmp = ((((CELLPTR) (CAR (symcell))) - scm_heap_org) << 8);
  register SCM z;
  if ((tmp >> 8) != ((CELLPTR) (CAR (symcell)) - scm_heap_org))
    tmp = 0;
  NEWCELL (z);
  SUBRF (z) = fcn;
  CAR (z) = tmp + type;
  CDR (symcell) = z;
  return z;
}

#ifdef CCLO
SCM 
scm_makcclo (proc, len)
     SCM proc;
     long len;
{
  SCM s;
  NEWCELL (s);
  DEFER_INTS;
  SETCHARS (s, scm_must_malloc (len * sizeof (SCM), "compiled-closure"));
  SETLENGTH (s, len, tc7_cclo);
  while (--len)
    VELTS (s)[len] = UNSPECIFIED;
  CCLO_SUBR (s) = proc;
  ALLOW_INTS;
  return s;
}
#endif


/* {Stack Checking}
 */

#ifdef STACK_LIMIT
void 
stack_check ()
{
  STACKITEM *start = BASE (rootcont);
  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 */
    scm_wta (SCM_UNDEFINED, (char *) SEGV_SIGNAL, "stack");
}

#endif
static long 
stack_size (start)
     STACKITEM *start;
{
  STACKITEM stack;
#ifdef STACK_GROWS_UP
  return &stack - start;
#else
  return start - &stack;
#endif /* def STACK_GROWS_UP */
}

void 
scm_stack_report ()
{
  STACKITEM stack;
  scm_intprint (stack_size (BASE (rootcont)) * sizeof (STACKITEM),
		16, cur_errp);
  scm_lputs (" of stack: 0x", cur_errp);
  scm_intprint ((long) BASE (rootcont), 16, cur_errp);
  scm_lputs (" - 0x", cur_errp);
  scm_intprint ((long) &stack, 16, cur_errp);
  scm_lputs ("\n", cur_errp);
}


/* {Continuations}
 */

SCM scm_throwval = SCM_UNDEFINED;

#define s_cont (ISYMCHARS(IM_CONT)+20)
SCM 
scm_make_cont ()
{
  long j;
  SCM cont;
#ifdef CHEAP_CONTINUATIONS
  NEWCELL (cont);
  DEFER_INTS;
  SETJMPBUF (cont, scm_must_malloc ((long) sizeof (regs), s_cont));
  CAR (cont) = tc7_contin;
  DYNENV (cont) = dynwinds;
  BASE (cont) = BASE (rootcont);
  SEQ (cont) = SEQ (rootcont);
  ALLOW_INTS;
#else
  register STACKITEM *src, *dst;
  NEWCELL (cont);
  DEFER_INTS;
  FLUSH_REGISTER_WINDOWS;
  j = stack_size (BASE (rootcont));
  SETJMPBUF (cont,
	     scm_must_malloc ((long) (sizeof (regs) + j * sizeof (STACKITEM)),
			      s_cont));
  SETLENGTH (cont, j, tc7_contin);
  DYNENV (cont) = dynwinds;
  src = BASE (cont) = BASE (rootcont);
  SEQ (cont) = SEQ (rootcont);
  ALLOW_INTS;
#ifndef STACK_GROWS_UP
  src -= LENGTH (cont);
#endif /* ndef STACK_GROWS_UP */
  dst = (STACKITEM *) (CHARS (cont) + sizeof (regs));
  for (j = LENGTH (cont); 0 <= --j;)
    *dst++ = *src++;
#endif /* def CHEAP_CONTINUATIONS */
  return cont;
}


void scm_dynthrow P ((SCM *a));

#ifndef CHEAP_CONTINUATIONS
static void 
grow_throw (a)			/* Grow the stack so that there is room */
     SCM *a;			/* to copy in the continuation.  Then */
{				/* retry the throw. */
  SCM growth[100];
  growth[0] = a[0];
  growth[1] = a[1];
  growth[2] = a[2] + 1;
  growth[3] = (SCM) a;
  scm_dynthrow (growth);
}
#endif /* ndef CHEAP_CONTINUATIONS */

void 
scm_dynthrow (a)
     SCM *a;
{
  SCM cont = a[0], val = a[1];
#ifndef CHEAP_CONTINUATIONS
  register long j;
  register STACKITEM *src, *dst = BASE (rootcont);
#ifdef STACK_GROWS_UP
  if (a[2] && (a - ((SCM *) a[3]) < 100))
#else
  if (a[2] && (((SCM *) a[3]) - a < 100))
#endif
    fputs ("grow_throw: check if SCM growth[100]; being optimized out\n",
	   stderr);
  /* if (a[2]) fprintf(stderr, " ct = %ld, dist = %ld\n",
			  a[2], (((SCM *)a[3]) - a)); */
#ifdef STACK_GROWS_UP
  if (PTR_GE (dst + LENGTH (cont), (STACKITEM *) & a))
    grow_throw (a);
#else
  dst -= LENGTH (cont);
  if (PTR_LE (dst, (STACKITEM *) & a))
    grow_throw (a);
#endif /* def STACK_GROWS_UP */
  FLUSH_REGISTER_WINDOWS;
  src = (STACKITEM *) (CHARS (cont) + sizeof (regs));
  for (j = LENGTH (cont); 0 <= --j;)
    *dst++ = *src++;
#ifdef sparc			/* clear out stack up to this stackframe */
  /* maybe this would help, maybe not */
/*	bzero((void *)&a, sizeof(STACKITEM) * (((STACKITEM *)&a) -
					       (dst - LENGTH(cont)))) */
#endif
#endif /* ndef CHEAP_CONTINUATIONS */
  scm_throwval = val;
  longjmp (JMPBUF (cont), 1);
}

void 
scm_lthrow (cont, val)
     SCM cont, val;
{
  SCM a[3];
  a[0] = cont;
  a[1] = val;
  a[2] = 0;
  if (   (SEQ (cont) != SEQ (rootcont))
      || (BASE (cont) != BASE (rootcont)))  /* base compare not needed */
    scm_wta (cont, "continuation from wrong top level", s_cont);
  
  scm_dowinds (DYNENV (cont),
	       scm_ilength (dynwinds) - scm_ilength (DYNENV (cont)));
  
  scm_dynthrow (a);
}


/* {GC marking}
 */

SCM 
scm_markcdr (ptr)
     SCM ptr;
{
  if GC8MARKP (ptr)
    return BOOL_F;
  SETGC8MARK (ptr);
  return CDR (ptr);
}

SCM 
scm_mark0 (ptr)
     SCM ptr;
{
  SETGC8MARK (ptr);
  return BOOL_F;
}

sizet 
scm_free0 (ptr)
     CELLPTR ptr;
{
  return 0;
}

SCM 
scm_equal0 (ptr1, ptr2)
     SCM ptr1, ptr2;
{
  return (CDR (ptr1) == CDR (ptr2)) ? BOOL_T : BOOL_F;
}


/* statically allocated port for diagnostic messages */
scm_cell scm_tmp_errp =
{(SCM) ((0L << 8) | tc16_fport | OPN | WRTNG), 0};

static char remsg[] = "remove\n#define ", addmsg[] = "add\n#define ";
extern sizet scm_num_protects;	/* scm_sys_protects now in scl.c */


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);
  scm_quit (MAKINUM (1L));
}

int scm_take_stdin = 0;

void 
scm_init_storage (stack_start_ptr, init_heap_size)
     STACKITEM *stack_start_ptr;
     long init_heap_size;
{
  sizet j = scm_num_protects;
  /* Because not all protects may get initialized */
  while (j)
    scm_sys_protects[--j] = BOOL_F;
  scm_tmp_errp.cdr = (SCM) stderr;
  cur_errp = PTR2SCM (&scm_tmp_errp);
  scm_freelist = EOL;
  scm_expmem = 0;

#ifdef SINGLES
  if (sizeof (float) != sizeof (long))
      fixconfig (remsg, "SINGLES", 0);
#endif /* def SINGLES */
#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);

  scm_mtrigger = INIT_MALLOC_LIMIT;
  scm_heap_table = ((struct heap_seg_data *)
		scm_must_malloc (sizeof (struct heap_seg_data),
				 scm_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, 1, &scm_freelist))
    {
      j = HEAP_SEG_SIZE;
      if (!init_heap_seg ((CELLPTR) malloc (j), j, 1, &scm_freelist))
	scm_wta (MAKINUM (j), (char *) NALLOC, scm_s_heap);
    }
  else
    scm_expmem = 1;
  scm_heap_org = CELL_UP (scm_heap_table[0].bounds[0]);
  /* scm_hplims[0] can change. do not remove scm_heap_org */

  /* Initialise the list of ports.  */
  scm_port_table = (struct scm_port_table *)
    scm_must_malloc ((long) (sizeof (struct scm_port_table)
		     * scm_port_table_room),
		     "port list");
  /* Initialise standard ports.  */
  NEWCELL (def_inp);
  if (scm_take_stdin)
    {
      CAR (def_inp) = (tc16_fport | OPN | RDNG);
      SETSTREAM (def_inp, stdin);
      if (isatty (fileno (stdin)))
	{
	  i_setbuf0 (def_inp);		/* turn off stdin buffering */
	  CAR (def_inp) |= BUF0;
	}
      scm_add_to_port_table (def_inp);
      scm_set_port_revealed (def_inp, MAKINUM (1));
    }
  else
    {
      SCM str;
      str = scm_makfromstr ("", 0, 0);
      CAR (def_inp) = (tc16_strport | OPN | RDNG);
      SETCHARS (def_inp, str);
    }
  NEWCELL (def_outp);
  CAR (def_outp) = (tc16_fport | OPN | WRTNG);
  SETSTREAM (def_outp, stdout);
  scm_add_to_port_table (def_outp);
  scm_set_port_revealed (def_outp, MAKINUM (1));
  NEWCELL (def_errp);
  CAR (def_errp) = (tc16_fport | OPN | WRTNG);
  SETSTREAM (def_errp, stderr);
  scm_add_to_port_table (def_errp);
  scm_set_port_revealed (def_errp, MAKINUM (1));
  cur_inp = def_inp;
  cur_outp = def_outp;
  cur_errp = def_errp;
  dynwinds = EOL;
  NEWCELL (rootcont);
  SETJMPBUF (rootcont, scm_must_malloc ((long) sizeof (regs), s_cont));
  CAR (rootcont) = tc7_contin;
  DYNENV (rootcont) = EOL;
  BASE (rootcont) = stack_start_ptr;
  listofnull = scm_cons (EOL, EOL);
  undefineds = scm_cons (SCM_UNDEFINED, EOL);
  CDR (undefineds) = undefineds;
  nullstr = scm_makstr (0L, 0);
  nullvect = scm_make_vector (INUM0, SCM_UNDEFINED);
  /* NEWCELL(nullvect);
	   CAR(nullvect) = tc7_vector;
	   SETCHARS(nullvect, NULL); */
  symhash = scm_make_vector ((SCM) MAKINUM (scm_symhash_dim), EOL);
  symhash_vars = scm_make_vector ((SCM) MAKINUM (scm_symhash_dim), EOL);
  scm_sysintern ("most-positive-fixnum", (SCM) MAKINUM (MOST_POSITIVE_FIXNUM));
  scm_sysintern ("most-negative-fixnum", (SCM) MAKINUM (MOST_NEGATIVE_FIXNUM));
  scm_sysintern ("*stdin*", def_inp);
  scm_sysintern ("*stdout*", def_outp);
  scm_sysintern ("*stderr*", def_errp);
#ifdef BIGDIG
  scm_sysintern ("bignum-radix", MAKINUM (BIGRAD));
#endif
  /* flo0 is now setup in scl.c */
  bad_throw_vcell = scm_sysintern ("%%bad-throw", BOOL_F);
}


struct array
{
  struct array * next;
  struct array * prev;
  int size;
  SCM elts[1];
};


static struct array * arrays;

/* Not safely interrupted. */
SCM *
scm_mkarray (size, fillp)
     int size;
     int fillp;
{
  int x;
  struct array * answer;
  answer = (struct array *)malloc (sizeof (*answer) + size * sizeof(SCM));
  if (!answer)
    return 0;
  answer->size = size;
  if (fillp)
    {
      int x;
      for (x = 0; x < size; ++x)
	answer->elts[x] = BOOL_F;
    }
  if (!arrays)
    {
      arrays = answer;
      answer->next = answer->prev = answer;
    }
  else
    {
      answer->next = arrays;
      answer->prev = arrays->prev;
      answer->next->prev = answer;
      answer->prev->next = answer;
    }

  return answer->elts;
}


/* Not safely implemented */
void
scm_free_array (elts)
     SCM * elts;
{
  struct array * it;
  it = (struct array *) ((char *)elts - (int)(&((struct array *)0)->elts));
  if (it == arrays)
    {
      if (it == it->next)
	arrays = 0;
      else
	arrays = it->next;
    }
  it->next->prev = it->prev;
  it->prev->next = it->next;
  free ((char *)it);
}


static void
mark_arrays ()
{
  struct array * pos;
  pos = arrays;
  if (!pos)
    return;
  do
    {
      int x;
      int size;
      SCM * elts;
      size = pos->size;
      elts = pos->elts;
      for (x = 0; x < size; ++x)
	scm_gc_mark (elts[x]);
      pos = pos->next;
    } while (pos != arrays);
}




/* 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
*/
SCM 
scm_gc_for_newcell ()
{
  SCM fl;
  gc_for_alloc (1, &scm_freelist);
  fl = scm_freelist;
  scm_freelist = CDR (fl);
  return fl;
}

static char s_bad_type[] = "unknown type in ";
jmp_buf scm_save_regs_gc_mark;

SCM 
scm_gc ()
{
  DEFER_INTS;
  scm_igc ("call");
  ALLOW_INTS;
  return UNSPECIFIED;
}

#define HUGE_LENGTH(x) (LENGTH_MAX==LENGTH(x) ? *((long *)VELTS(x)) : LENGTH(x))

static void 
gc_sweep ()
{
  register CELLPTR ptr;
#ifdef POINTERS_MUNGED
  register SCM scmptr;
#else
#define scmptr (SCM)ptr
#endif
  register SCM nfreelist;
  register SCM *hp_freelist;
  register long n;
  register long m;
  register sizet j;
  register int span;
  sizet i;
  sizet seg_size;

  n = 0;
  m = 0;
  i = 0;

  while (i < scm_n_heap_segs)
    {
      hp_freelist = scm_heap_table[i].freelistp;
      nfreelist = EOL;
      span = scm_heap_table[i].ncells;
      ptr = CELL_UP (scm_heap_table[i].bounds[0]);
      seg_size = CELL_DN (scm_heap_table[i].bounds[1]) - ptr;
      ++i;
      for (j = seg_size + span; j -= span; ptr += span)
	{
#ifdef POINTERS_MUNGED
	  scmptr = PTR2SCM (ptr);
#endif
	  switch TYP7 (scmptr)
	    {
	    case tcs_cons_gloc:
	      if (GCMARKP (scmptr))
		{
		  if (CDR (CAR (scmptr) - 1) == (SCM)1)
		    CDR (CAR (scmptr) - 1) = (SCM)0;
		  goto cmrkcontinue;
		}
	      {
		SCM vcell;
		vcell = CAR (scmptr) - 1L;
		if ((CDR (vcell) == 0) || (CDR (vcell) == 1))
		  {
		    free ((char *)CDR (scmptr));
		    m += sizeof (SCM) * (LENGTH (((SCM *)vcell)[struct_i_format]));
		    CDR (scmptr) = BOOL_F;
		    --((SCM *)vcell)[struct_i_refcnt];
		  }
	      }
	      break;
	    case tcs_cons_imcar:
	    case tcs_cons_nimcar:
	    case tcs_closures:
	      if (GCMARKP (scmptr))
		goto cmrkcontinue;
	      break;
	    case tc7_vector:
	    case tc7_lvector:
#ifdef CCLO
	    case tc7_cclo:
#endif
	      if (GC8MARKP (scmptr))
		goto c8mrkcontinue;
	      m += (LENGTH (scmptr) * sizeof (SCM));
	    freechars:
	      scm_must_free (CHARS (scmptr));
	      /*	SETCHARS(scmptr, 0);*/
	      break;
	    case tc7_bvect:
	      if GC8MARKP (scmptr)
		goto c8mrkcontinue;
	      m += 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);
	      goto freechars;
	    case tc7_fvect:
	      if GC8MARKP (scmptr)
		goto c8mrkcontinue;
	      m += HUGE_LENGTH (scmptr) * sizeof (float);
	      goto freechars;
	    case tc7_dvect:
	      if GC8MARKP (scmptr)
		goto c8mrkcontinue;
	      m += HUGE_LENGTH (scmptr) * sizeof (double);
	      goto freechars;
	    case tc7_cvect:
	      if GC8MARKP (scmptr)
		goto c8mrkcontinue;
	      m += HUGE_LENGTH (scmptr) * 2 * sizeof (double);
	      goto freechars;
	    case tc7_string:
	      if (GC8MARKP (scmptr))
		goto c8mrkcontinue;
	      m += HUGE_LENGTH (scmptr) + 1;
	      goto freechars;
	    case tc7_msymbol:
	      if (GC8MARKP (scmptr))
		goto c8mrkcontinue;
	      m += LENGTH (scmptr) + 1;
	    freeslots:
	      scm_must_free ((char *)SLOTS (scmptr));
	      break;
	    case tc7_contin:
	      if GC8MARKP (scmptr)
		goto c8mrkcontinue;
	      m += LENGTH (scmptr) * sizeof (STACKITEM) + sizeof (regs);
	      goto freechars;
	    case tc7_ssymbol:
	      if GC8MARKP(scmptr)
		goto c8mrkcontinue;
	      break;
	    case tcs_subrs:
	      continue;
	    case tc7_port:
	      if GC8MARKP (scmptr)
		goto c8mrkcontinue;
	      if OPENP (scmptr)
		{
		  int k = PTOBNUM (scmptr);
		  if (!(k < scm_numptob))
		    goto sweeperr;
		  /* Keep "revealed" ports alive.  */
		  if (scm_revealed_count(scmptr) > 0)
		    continue;
		  /* Yes, I really do mean scm_ptobs[k].free */
		  /* rather than ftobs[k].close.  .close */
		  /* is for explicit CLOSE-PORT by user */
		  (scm_ptobs[k].free) (STREAM (scmptr));
		  scm_remove_from_port_table (scmptr);
		  scm_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;
		  m += (NUMDIGS (scmptr) * BITSPERDIG / CHAR_BIT);
		  goto freechars;
#endif /* def BIGDIG */
		case tc16_flo:
		  if GC8MARKP (scmptr)
		    goto c8mrkcontinue;
		  switch ((int) (CAR (scmptr) >> 16))
		    {
		    case (IMAG_PART | REAL_PART) >> 16:
		      m += sizeof (double);
		    case REAL_PART >> 16:
		    case IMAG_PART >> 16:
		      m += sizeof (double);
		      goto freechars;
		    case 0:
		      break;
		    default:
		      goto sweeperr;
		    }
		  break;
		default:
		  if GC8MARKP (scmptr)
		    goto c8mrkcontinue;

		  {
		    int k;
		    k = SMOBNUM (scmptr);
		    if (!(k < scm_numsmob))
		      goto sweeperr;
		    m += (scm_smobs[k].free) ((CELLPTR) scmptr);
		    break;
		  }
		}
	      break;
	    default:
	    sweeperr:scm_wta (scmptr, s_bad_type, "gc_sweep");
	    }
	  n += span;
#if 0
	  if (CAR (scmptr) == (SCM) tc_free_cell)
	    exit (2);
#endif
	  CAR (scmptr) = (SCM) tc_free_cell;
	  CDR (scmptr) = nfreelist;
	  nfreelist = scmptr;
#if 0
	  if ((nfreelist < scm_heap_table[0].bounds[0]) ||
	      (nfreelist >= scm_heap_table[0].bounds[1]))
	    exit (1);
#endif
	  continue;
	c8mrkcontinue:
	  CLRGC8MARK (scmptr);
	  continue;
	cmrkcontinue:
	  CLRGCMARK (scmptr);
	}
#ifdef GC_FREE_SEGMENTS
      if (n == seg_size)
	{
	  scm_heap_size -= seg_size;
	  scm_must_free ((char *) scm_heap_table[i - 1].bounds[0]);
	  scm_heap_table[i - 1].bounds[0] = 0;
	  for (j = i; j < scm_n_heap_segs; j++)
	    scm_heap_table[j - 1] = scm_heap_table[j];
	  scm_n_heap_segs -= 1;
	  i -= 1;		/* need to scan segment just moved. */
	}
      else
#endif /* ifdef GC_FREE_SEGMENTS */
	*hp_freelist = nfreelist;

      scm_gc_cells_collected += n;
      n = 0;
    }
  scm_lcells_allocated += (   scm_heap_size
			   - scm_gc_cells_collected
			   - scm_cells_allocated);
  scm_cells_allocated = (scm_heap_size - scm_gc_cells_collected);
  scm_lmallocated -= m;
  scm_mallocated -= m;
  scm_gc_malloc_collected = m;
}

STACKITEM * scm_stack_base = 0;

void
scm_igc (what)
     char *what;
{
  int j;
  long oheap_size;

  j = scm_num_protects;
  oheap_size = scm_heap_size;

  scm_gc_start (what);
  ++scm_errjmp_bad;

  {
    SCM type_list;
    SCM * pos;

    pos = &type_obj_list;
    type_list = type_obj_list;
    while (type_list != EOL)
      if (VELTS (CAR (type_list))[struct_i_refcnt])
	{
	  pos = &CDR (type_list);
	  type_list = CDR (type_list);
	}
      else
	{
	  *pos = CDR (type_list);
	  type_list = CDR (type_list);
	}
  }

  while (j--)
    scm_gc_mark (scm_sys_protects[j]);

  mark_arrays ();

  FLUSH_REGISTER_WINDOWS;
  /* This assumes that all registers are saved into the jmp_buf */
  setjmp (scm_save_regs_gc_mark);
  scm_mark_locations ((STACKITEM *) scm_save_regs_gc_mark,
		      (   (sizet) sizeof scm_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) - scm_stack_base;
#else
    long stack_len = stack_size (scm_stack_base);
#endif
    scm_mark_locations (scm_stack_base, (sizet) stack_len);
#else
#ifdef nosve
    long stack_len = scm_stack_base - (STACKITEM *) (&stack_len);
#else
    long stack_len = stack_size (scm_stack_base);
#endif
    scm_mark_locations ((scm_stack_base - stack_len), (sizet) stack_len);
#endif
  }
  gc_sweep ();

  --scm_errjmp_bad;
  scm_gc_end ();


  if (oheap_size != scm_heap_size)
    {
      ALLOW_INTS;
      scm_growth_mon (scm_s_heap, scm_heap_size, scm_s_cells);
      DEFER_INTS;
    }
}

static char s_not_free[] = "not freed";
void 
scm_free_storage ()
{
  sizet i = 0;

  DEFER_INTS;
  scm_gc_start ("free");
  ++scm_errjmp_bad;
  cur_inp = BOOL_F;
  cur_outp = BOOL_F;
  cur_errp = PTR2SCM (&scm_tmp_errp);
  scm_gc_mark (def_inp);	/* don't want to close stdin */
  scm_gc_mark (def_outp);	/* don't want to close stdout */
  scm_gc_mark (def_errp);	/* don't want to close stderr */
  gc_sweep ();
  rootcont = BOOL_F;
  while (i < scm_n_heap_segs)
    {				/* free heap segments */
      CELLPTR ptr;
      sizet seg_size;

      ptr = CELL_UP (scm_heap_table[i].bounds[0]);
      seg_size = CELL_DN (scm_heap_table[i].bounds[1]) - ptr;
      scm_heap_size -= seg_size;
      scm_must_free ((char *) scm_heap_table[i].bounds[0]);
      scm_heap_table[i].bounds[0] = 0;
      scm_growth_mon (scm_s_heap, scm_heap_size, scm_s_cells);
      ++i;
    }
  if (scm_heap_size)
    scm_wta (MAKINUM (scm_heap_size), s_not_free, scm_s_heap);

  /* Not all cells get freed (see scm_gc_mark() calls above). */
  /* if (scm_cells_allocated) scm_wta(MAKINUM(scm_cells_allocated), s_not_free, "cells"); */
  /* either there is a small memory leak or I am counting wrong. */
  /* if (scm_mallocated) scm_wta(MAKINUM(scm_mallocated), s_not_free, "malloc"); */

  scm_must_free ((char *) scm_heap_table);
  scm_heap_table = 0;
  scm_must_free ((char *) scm_smobs);
  scm_smobs = 0;
  scm_gc_end ();
  ALLOW_INTS;			/* A really bad idea, but printing does it anyway. */
  scm_exit_report ();
  scm_must_free ((char *) scm_ptobs);
  scm_ptobs = 0;
  scm_lmallocated = scm_mallocated = 0;
  /* Can't do scm_gc_end() here because it uses scm_ptobs which have been freed */
}

void 
scm_gc_mark (p)
     SCM p;
{
  register long i;
  register SCM ptr;

  ptr = p;

gc_mark_loop:
  if (IMP (ptr))
    return;

gc_mark_nimp:
  if (NCELLP (ptr))
    scm_wta (ptr, "rogue pointer in ", scm_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;
	}
      scm_gc_mark (CAR (ptr));
      ptr = GCCDR (ptr);
      goto gc_mark_nimp;
    case tcs_cons_imcar:
      if (GCMARKP (ptr))
	break;
      SETGCMARK (ptr);
      ptr = GCCDR (ptr);
      goto gc_mark_loop;
    case tcs_cons_gloc:
      if (GCMARKP (ptr))
	break;
      SETGCMARK (ptr);
      {
	SCM vcell;
	vcell = CAR (ptr) - 1L;
	switch (CDR (vcell))
	  {
	  default:
	    scm_gc_mark (vcell);
	    ptr = GCCDR (ptr);
	    goto gc_mark_loop;
	  case 1:		/* ! */
	  case 0:		/* ! */
	    {
	      char * format;
	      int len;
	      int i;
	      SCM * mem;
	      format = CHARS ( ((SCM *)vcell)[struct_i_format] );
	      len = LENGTH  ( ((SCM *)vcell)[struct_i_format] );
	      mem = (SCM *)GCCDR (ptr);
	      for (i = 0; i < len; ++i, ++format)
		if ((*format == 's') || (*format == 'S'))
		  scm_gc_mark (mem[i]);
		else if (*format == '*')
		  {
		    int vlen;
		    vlen = mem[i];
		    ++format;
		    ++i;
		    if ((*format == 's') ||  (*format == 'S'))
		      {
			int j;
			for (j = 0; j < vlen; ++j)
			  scm_gc_mark (mem[i + j]);
		      }
		  }
	    }
	    if (!CDR (vcell))
	      {
		SETGCMARK (vcell);
		ptr = ((SCM *)vcell)[struct_i_self];
		goto gc_mark_loop;
	      }
	  }
      }
      break;
    case tcs_closures:
      if (GCMARKP (ptr))
	break;
      SETGCMARK (ptr);
      if (IMP (CDR (ptr)))
	{
	  ptr = CLOSCAR (ptr);
	  goto gc_mark_nimp;
	}
      scm_gc_mark (CLOSCAR (ptr));
      ptr = GCCDR (ptr);
      goto gc_mark_nimp;
    case tc7_vector:
    case tc7_lvector:
#ifdef CCLO
    case tc7_cclo:
#endif
      if (GC8MARKP (ptr))
	break;
      SETGC8MARK (ptr);
      i = LENGTH (ptr);
      if (i == 0)
	break;
      while (--i > 0)
	if (NIMP (VELTS (ptr)[i]))
	  scm_gc_mark (VELTS (ptr)[i]);
      ptr = VELTS (ptr)[0];
      goto gc_mark_loop;
    case tc7_contin:
      if GC8MARKP
	(ptr) break;
      SETGC8MARK (ptr);
      scm_mark_locations (VELTS (ptr),
	       (sizet) (LENGTH (ptr) + sizeof (regs) / sizeof (STACKITEM)));
      break;
    case tc7_bvect:
    case tc7_ivect:
    case tc7_uvect:
    case tc7_fvect:
    case tc7_dvect:
    case tc7_cvect:
    case tc7_string:
      SETGC8MARK (ptr);
      break;
    case tc7_msymbol:
      if (GC8MARKP(ptr))
	break;
      SETGC8MARK (ptr);
      scm_gc_mark (SYMBOL_FUNC (ptr));
      ptr = SYMBOL_PROPS (ptr);
      goto gc_mark_loop;
    case tc7_ssymbol:
      if (GC8MARKP(ptr))
	break;
      SETGC8MARK (ptr);
      break;
    case tcs_subrs:
      break;
    case tc7_port:
      i = PTOBNUM (ptr);
      if (!(i < scm_numptob))
	goto def;
      ptr = (scm_ptobs[i].mark) (ptr);
      goto gc_mark_loop;
      break;
    case tc7_smob:
      if (GC8MARKP (ptr))
	break;
      switch TYP16 (ptr)
	{ /* should be faster than going through scm_smobs */
	case tc_free_cell:
	  /* printf("found free_cell %X ", ptr); fflush(stdout); */
	  SETGC8MARK (ptr);
	  CDR (ptr) = EOL;
	  break;
	case tcs_bignums:
	case tc16_flo:
	  SETGC8MARK (ptr);
	  break;
	default:
	  i = SMOBNUM (ptr);
	  if (!(i < scm_numsmob))
	    goto def;
	  ptr = (scm_smobs[i].mark) (ptr);
	  goto gc_mark_loop;
	}
      break;
    default:
    def:scm_wta (ptr, s_bad_type, "gc_mark");
    }
}

void 
scm_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 = scm_n_heap_segs - 1;
	if (   PTR_LE (scm_heap_table[i].bounds[0], ptr)
	    && PTR_GT (scm_heap_table[j].bounds[1], ptr))
	  {
	    while (i <= j)
	      {
		int seg_id;
		seg_id = -1;
		if (   (i == j)
		    || PTR_GT (scm_heap_table[i].bounds[1], ptr))
		  seg_id = i;
		else if (PTR_LE (scm_heap_table[j].bounds[0], ptr))
		  seg_id = j;
		else
		  {
		    int k;
		    k = (i + j) / 2;
		    if (k == i)
		      break;
		    if (PTR_GT (scm_heap_table[k].bounds[1], ptr))
		      {
			j = k;
			++i;
			if (PTR_LE (scm_heap_table[i].bounds[0], ptr))
			  continue;
			else
			  break;
		      }
		    else if (PTR_LE (scm_heap_table[k].bounds[0], ptr))
		      {
			i = k;
			--j;
			if (PTR_GT (scm_heap_table[j].bounds[1], ptr))
			  continue;
			else
			  break;
		      }
		  }
		if (   !scm_heap_table[seg_id].valid
		    || scm_heap_table[seg_id].valid (ptr,
						     &scm_heap_table[seg_id]))
		  scm_gc_mark (*(SCM *) & x[m]);
		break;
	      }

	  }
      }
}
