/* 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 "scm.h"
#include "setjump.h"
#include <fcntl.h>
#include <errno.h>


unsigned char scm_upcase[CHAR_CODE_LIMIT];
unsigned char scm_downcase[CHAR_CODE_LIMIT];
unsigned char scm_lowers[] = "abcdefghijklmnopqrstuvwxyz";
unsigned char scm_uppers[] = "ABCDEFGHIJKLMNOPQRSTUVWXYZ";

extern int scm_verbose;
void 
scm_init_tables ()
{
  int i;
  for (i = 0; i < CHAR_CODE_LIMIT; i++)
    scm_upcase[i] = scm_downcase[i] = i;
  for (i = 0; i < sizeof scm_lowers / sizeof (char); i++)
    {
      scm_upcase[scm_lowers[i]] = scm_uppers[i];
      scm_downcase[scm_uppers[i]] = scm_lowers[i];
    }
  scm_verbose = 1;		/* Here so that monitor info won't be */
  /* printed while in scm_init_storage. (BOOM) */
}

#ifdef EBCDIC
char *scm_charnames[] =
{
  "nul","soh","stx","etx", "pf", "ht", "lc","del",
   0   , 0   ,"smm", "vt", "ff", "cr", "so", "si",
  "dle","dc1","dc2","dc3","res", "nl", "bs", "il",
  "can", "em", "cc", 0   ,"ifs","igs","irs","ius",
   "ds","sos", "fs", 0   ,"byp", "lf","eob","pre",
   0   , 0   , "sm", 0   , 0   ,"enq","ack","bel",
   0   , 0   ,"syn", 0   , "pn", "rs", "uc","eot",
   0   , 0   , 0   , 0   ,"dc4","nak", 0   ,"sub",
   "space", scm_s_newline, "tab", "backspace", "return", "page", "null"};
char scm_charnums[] =
"\000\001\002\003\004\005\006\007\
\010\011\012\013\014\015\016\017\
\020\021\022\023\024\025\026\027\
\030\031\032\033\034\035\036\037\
\040\041\042\043\044\045\046\047\
\050\051\052\053\054\055\056\057\
\060\061\062\063\064\065\066\067\
\070\071\072\073\074\075\076\077\
 \n\t\b\r\f\0";
#endif /* def EBCDIC */
#ifdef ASCII
char *scm_charnames[] =
{
  "nul","soh","stx","etx","eot","enq","ack","bel",
   "bs", "ht", "nl", "vt", "np", "cr", "so", "si",
  "dle","dc1","dc2","dc3","dc4","nak","syn","etb",
  "can", "em","sub","esc", "fs", "gs", "rs", "us",
  "space", scm_s_newline, "tab", "backspace", "return", "page", "null", "del"};
char scm_charnums[] =
"\000\001\002\003\004\005\006\007\
\010\011\012\013\014\015\016\017\
\020\021\022\023\024\025\026\027\
\030\031\032\033\034\035\036\037\
 \n\t\b\r\f\0\177";
#endif /* def ASCII */


/* Local functions needing declarations.
 */

static SCM lreadr P ((SCM tok_buf, SCM port, int case_i));
static SCM lreadparen P ((SCM tok_buf, SCM port, char *name, int case_i));
static sizet read_token P ((int ic, SCM tok_buf, SCM port, int case_i,
			    int weird));


/* {Names of immediate symbols}
 * 
 * This table must agree with the declarations in scm.h: {Immediate Symbols}.
 */

char *scm_isymnames[] =
{
  /* This table must agree with the declarations */
  "#@and",
  "#@begin",
  "#@case",
  "#@cond",
  "#@do",
  "#@if",
  "#@lambda",
  "#@let",
  "#@let*",
  "#@letrec",
  "#@or",
  "#@quote",
  "#@set!",
  "#@define",
#if 0
  "#@literal-variable-ref",
  "#@literal-variable-set!",
#endif
  "#@apply",
  "#@call-with-current-continuation",

 /* user visible ISYMS */
 /* other keywords */
 /* Flags */

  "#f",
  "#t",
  "#<undefined>",
  "#<eof>",
  "()",
  "#<unspecified>"
};

/* {Printing of Scheme Objects}
 */

/* Print an integer.
 */
void 
scm_intprint (n, radix, port)
     long n;
     int radix;
     SCM port;
{
  char num_buf[INTBUFLEN];
  scm_lfwrite (num_buf, (sizet) sizeof (char), scm_iint2str (n, radix, num_buf), port);
}

/* Print an object of unrecognized type.
 */
void 
scm_ipruk (hdr, ptr, port)
     char *hdr;
     SCM ptr;
     SCM port;
{
  scm_lputs ("#<unknown-", port);
  scm_lputs (hdr, port);
  if (CELLP (ptr))
    {
      scm_lputs (" (0x", port);
      scm_intprint (CAR (ptr), 16, port);
      scm_lputs (" . 0x", port);
      scm_intprint (CDR (ptr), 16, port);
      scm_lputs (") @", port);
    }
  scm_lputs (" 0x", port);
  scm_intprint (ptr, 16, port);
  scm_lputc ('>', port);
}

/* Print a list.
 */
void 
scm_iprlist (hdr, exp, tlr, port, writing)
     char *hdr, tlr;
     SCM exp;
     SCM port;
     int writing;
{
  scm_lputs (hdr, port);
  /* CHECK_INTS; */
  scm_iprin1 (CAR (exp), port, writing);
  exp = CDR (exp);
  for (; NIMP (exp); exp = CDR (exp))
    {
      if (NECONSP (exp))
	break;
      scm_lputc (' ', port);
      /* CHECK_INTS; */
      scm_iprin1 (CAR (exp), port, writing);
    }
  if (NNULLP (exp))
    {
      scm_lputs (" . ", port);
      scm_iprin1 (exp, port, writing);
    }
  scm_lputc (tlr, port);
}

/* Print generally.  Handles both write and display according to WRITING.
 */
void 
scm_iprin1 (exp, port, writing)
     SCM exp;
     SCM port;
     int writing;
{
  register long i;
taloop:
  switch (7 & (int) exp)
    {
    case 2:
    case 6:
      scm_intprint (INUM (exp), 10, port);
      break;
    case 4:
      if (ICHRP (exp))
	{
	  i = ICHR (exp);
	  if (writing)
	    scm_lputs ("#\\", port);
	  if (!writing)
	    scm_lputc ((int) i, port);
	  else if ((i <= ' ') && scm_charnames[i])
	    scm_lputs (scm_charnames[i], port);
#ifndef EBCDIC
	  else if (i == '\177')
	    scm_lputs (scm_charnames[(sizeof scm_charnames / sizeof (char *)) - 1], port);
#endif /* ndef EBCDIC */
	  else if (i > '\177')
	    scm_intprint (i, 8, port);
	  else
	    scm_lputc ((int) i, port);
	}
      else if (   IFLAGP (exp)
	       && (ISYMNUM (exp) < (sizeof scm_isymnames / sizeof (char *))))
	  scm_lputs (ISYMCHARS (exp), port);
      else if (ILOCP (exp))
	{
	  scm_lputs ("#@", port);
	  scm_intprint ((long) IFRAME (exp), 10, port);
	  scm_lputc (ICDRP (exp) ? '-' : '+', port);
	  scm_intprint ((long) IDIST (exp), 10, port);
	}
      else
	goto idef;
      break;
    case 1:
      /* gloc */
      scm_lputs ("#@", port);
      exp = CAR (exp - 1);
      goto taloop;
    default:
    idef:
      scm_ipruk ("immediate", exp, port);
      break;
    case 0:
      switch (TYP7 (exp))
	{
	case tcs_cons_gloc:
	  if (CDR (CAR (exp) - 1L) == 0)
	    {
	      SCM name;
	      scm_lfwrite ("#<latte ",
			   (sizet) sizeof (char),
			   (sizet) 8,
			   port);
	      name = ((SCM *)(STRUCT_TYPE( exp)))[struct_i_name];
	      scm_lfwrite (CHARS (name),
			   (sizet) sizeof (char),
			   (sizet) LENGTH (name),
			   port);
	      scm_lputc (' ', port);
	      scm_intprint(exp, 16, port);
	      scm_lputc ('>', port);
	      break;
	    }
	case tcs_cons_imcar:
	case tcs_cons_nimcar:
	  scm_iprlist ("(", exp, ')', port, writing);
	  break;
	case tcs_closures:
	  exp = CODE (exp);
	  scm_iprlist ("#<CLOSURE ", exp, '>', port, writing);
	  break;
	case tc7_string:
	  if (writing)
	    {
	      scm_lputc ('\"', port);
	      for (i = 0; i < LENGTH (exp); ++i)
		switch (CHARS (exp)[i])
		  {
		  case '\"':
		  case '\\':
		    scm_lputc ('\\', port);
		  default:
		    scm_lputc (CHARS (exp)[i], port);
		  }
	      scm_lputc ('\"', port);
	      break;
	    }
	  else
	    scm_lfwrite (CHARS (exp),
			 (sizet) sizeof (char),
			 (sizet) LENGTH (exp),
			 port);
	  break;
	case tcs_symbols:
	  {
	    int pos;
	    int end;
	    int len;
	    char * str;
	    int weird;
	    int maybe_weird;
	    int mw_pos;

	    len = LENGTH (exp);
	    str = CHARS (exp);
	    scm_remember (&exp);
	    pos = 0;
	    weird = 0;
	    maybe_weird = 0;

	    for (end = pos; end < len; ++end)
	      switch (str[end])
		{
#ifdef BRACKETS_AS_PARENS
		case '[':
		case ']':
#endif
		case '(':
		case ')':
		case '\"':
		case ';':
		case WHITE_SPACES:
		case LINE_INCREMENTORS:
		weird_handler:
		  if (maybe_weird)
		    {
		      end = mw_pos;
		      maybe_weird = 0;
		    }
		  if (!weird)
		    {
		      scm_lfwrite ("#{", (sizet) sizeof(char), 2, port);
		      weird = 1;
		    }
		  if (pos < end)
		    {
		      scm_lfwrite (str + pos, sizeof (char), end - pos, port);
		    }
		  {
		    char buf[2];
		    buf[0] = '\\';
		    buf[1] = str[end];
		    scm_lfwrite (buf, (sizet) sizeof (char), 2, port);
		  }
		  pos = end + 1;
		  break;
		case '\\':
		  if (weird)
		    goto weird_handler;
		  if (!maybe_weird)
		    {
		      maybe_weird = 1;
		      mw_pos = pos;
		    }
		  break;
		case '}':
		case '#':
		  if (weird)
		    goto weird_handler;
		  break;
		default:
		  break;
		}
	    if (pos < end)
	      scm_lfwrite (str + pos, (sizet) sizeof (char), end - pos, port);
	    if (weird)
	      scm_lfwrite ("}#", (sizet) sizeof (char), 2, port);
	    break;
	  }
	case tc7_vector:
	  scm_lputs ("#(", port);
	  for (i = 0; i + 1 < LENGTH (exp); ++i)
	    {
	      /* CHECK_INTS; */
	      scm_iprin1 (VELTS (exp)[i], port, writing);
	      scm_lputc (' ', port);
	    }
	  if (i < LENGTH (exp))
	    {
	      /* CHECK_INTS; */
	      scm_iprin1 (VELTS (exp)[i], port, writing);
	    }
	  scm_lputc (')', port);
	  break;
	case tc7_lvector:
	  {
	    SCM result;
	    SCM hook;
	    hook = scm_get_lvector_hook (exp, LV_PRINT_FN);
	    if (hook == BOOL_F)
	      {
		scm_lputs ("#<locked-vector ", port);
		scm_intprint(CDR(exp), 16, port);
		scm_lputs (">", port);
	      }
	    else
	      {
		result
		  = scm_apply (hook,
			       scm_cons (exp,
					 scm_cons (port,
						   scm_cons ((writing
							      ? BOOL_T
							      : BOOL_F),
							     EOL))),
			       EOL);
		if (result == BOOL_F)
		  goto punk;
	      }
	    break;
	  }
	  break;
	case tc7_bvect:
	case tc7_ivect:
	case tc7_uvect:
	case tc7_fvect:
	case tc7_dvect:
	case tc7_cvect:
	  scm_raprin1 (exp, port, writing);
	  break;
	case tcs_subrs:
	  scm_lputs ("#<primitive-procedure ", port);
	  scm_lputs (CHARS (SNAME (exp)), port);
	  scm_lputc ('>', port);
	  break;
#ifdef CCLO
	case tc7_cclo:
	  scm_lputs ("#<compiled-closure ", port);
	  scm_iprin1 (CCLO_SUBR (exp), port, writing);
	  scm_lputc ('>', port);
	  break;
#endif
	case tc7_contin:
	  scm_lputs ("#<continuation ", port);
	  scm_intprint (LENGTH (exp), 10, port);
	  scm_lputs (" @ ", port);
	  scm_intprint ((long) CHARS (exp), 16, port);
	  scm_lputc ('>', port);
	  break;
	case tc7_port:
	  i = PTOBNUM (exp);
	  if (i < scm_numptob && scm_ptobs[i].print && (scm_ptobs[i].print) (exp, port, writing))
	    break;
	  goto punk;
	case tc7_smob:
	  i = SMOBNUM (exp);
	  if (i < scm_numsmob && scm_smobs[i].print
	      && (scm_smobs[i].print) (exp, port, writing))
	    break;
	  goto punk;
	default:
	punk:scm_ipruk ("type", exp, port);
	}
    }
}

/* Various I/O primitives, leading up to READ
 */

#ifdef __IBMC__
# define MSDOS
#endif
#ifdef MSDOS
# ifndef GO32
#  include <io.h>
#  include <conio.h>
static int 
input_waiting (f)
     FILE *f;
{
  if (feof (f))
    return 1;
  if (fileno (f) == fileno (stdin) && (isatty (fileno (stdin))))
    return kbhit ();
  return -1;
}
# endif
#else
# ifdef _DCC
#  include <ioctl.h>
# else
#  ifndef AMIGA
#   ifndef vms
#    ifdef MWC
#     include <sys/io.h>
#    else
#     ifndef THINK_C
#      ifndef ARM_ULIB
#       include <sys/ioctl.h>
#      endif
#     endif
#    endif
#   endif
#  endif
# endif


static int input_waiting(f)
     FILE *f;
{
# ifdef FIONREAD
  long remir;
  if (feof(f)) return 1;
  ioctl(fileno(f), FIONREAD, &remir);
  return remir;
# else
  return -1;
# endif
}
#endif

/* perhaps should undefine MSDOS from __IBMC__ here */
#ifndef GO32
static char s_char_readyp[] = "char-ready?";
SCM 
scm_char_readyp (port)
     SCM port;
{
  if (UNBNDP (port))
    port = cur_inp;
  else
    ASSERT (NIMP (port) && OPINPORTP (port), port, ARG1, s_char_readyp);
  if (CRDYP (port) || !FPORTP (port))
    return BOOL_T;
  return input_waiting (STREAM (port)) ? BOOL_T : BOOL_F;
}
#endif

SCM 
scm_eof_objectp (x)
     SCM x;
{
  return (EOF_VAL == x) ? BOOL_T : BOOL_F;
}

void 
scm_lfflush (port)		/* internal SCM call */
     SCM port;
{
  sizet i = PTOBNUM (port);
  (scm_ptobs[i].fflush) (STREAM (port));
}

static char s_flush[] = "force-output";
SCM 
scm_lflush (port)		/* user accessible as scm_force-output */
     SCM port;
{
  if (UNBNDP (port))
 port = cur_outp;
  else
    ASSERT (NIMP (port) && OPOUTPORTP (port), port, ARG1, s_flush);
  {
    sizet i = PTOBNUM (port);
    SYSCALL ((scm_ptobs[i].fflush) (STREAM (port)));
    return UNSPECIFIED;
  }
}

static char scm_s_write[] = "write";
SCM 
scm_lwrite (obj, port)
     SCM obj, port;
{
  if (UNBNDP (port))
    port = cur_outp;
  else
    ASSERT (NIMP (port) && OPOUTPORTP (port), port, ARG2, scm_s_write);
  scm_iprin1 (obj, port, 1);
#ifdef HAVE_PIPE
# ifdef EPIPE
  if (EPIPE == errno)
    scm_close_port (port);
# endif
#endif
  return UNSPECIFIED;
}

static char s_display[] = "display";
SCM 
scm_display (obj, port)
     SCM obj, port;
{
  if (UNBNDP (port))
 port = cur_outp;
  else
    ASSERT (NIMP (port) && OPOUTPORTP (port), port, ARG2, s_display);
  scm_iprin1 (obj, port, 0);
#ifdef HAVE_PIPE
# ifdef EPIPE
  if (EPIPE == errno)
    scm_close_port (port);
# endif
#endif
  return UNSPECIFIED;
}

char scm_s_newline[] = "newline";
SCM 
scm_newline (port)
     SCM port;
{
  if (UNBNDP (port))
 port = cur_outp;
  else
    ASSERT (NIMP (port) && OPOUTPORTP (port), port, ARG1, scm_s_newline);
  scm_lputc ('\n', port);
#ifdef HAVE_PIPE
# ifdef EPIPE
  if (EPIPE == errno)
    scm_close_port (port);
  else
# endif
#endif
  if (port == cur_outp)
    scm_lfflush (port);
  return UNSPECIFIED;
}

static char s_write_char[] = "write-char";
SCM 
scm_write_char (chr, port)
     SCM chr, port;
{
  if (UNBNDP (port))
 port = cur_outp;
  else
    ASSERT (NIMP (port) && OPOUTPORTP (port), port, ARG2, s_write_char);
  ASSERT (ICHRP (chr), chr, ARG1, s_write_char);
  scm_lputc ((int) ICHR (chr), port);
#ifdef HAVE_PIPE
# ifdef EPIPE
  if (EPIPE == errno)
    scm_close_port (port);
# endif
#endif
  return UNSPECIFIED;
}

FILE *scm_trans = 0;
SCM 
scm_trans_on (fil)
     SCM fil;
{
  transcript = scm_open_file (fil,
			      scm_makfromstr ("w", (sizet) sizeof (char), 0));
  if (FALSEP (transcript))
    scm_trans = 0;
  else
    scm_trans = STREAM (transcript);
  return UNSPECIFIED;
}

SCM 
scm_trans_off ()
{
  if (!FALSEP (transcript))
    scm_close_port (transcript);
  transcript = BOOL_F;
  scm_trans = 0;
  return UNSPECIFIED;
}

void 
scm_lputc (c, port)
     int c;
     SCM port;
{
  sizet i = PTOBNUM (port);
  SYSCALL ((scm_ptobs[i].fputc) (c, STREAM (port)));
  if (scm_trans && (port == def_outp || port == cur_errp))
    SYSCALL (fputc (c, scm_trans));
}

void 
scm_lputs (s, port)
     char *s;
     SCM port;
{
  sizet i = PTOBNUM (port);
  SYSCALL ((scm_ptobs[i].fputs) (s, STREAM (port)));
  if (scm_trans && (port == def_outp || port == cur_errp))
    SYSCALL (fputs (s, scm_trans));
}

int 
scm_lfwrite (ptr, size, nitems, port)
     char *ptr;
     sizet size;
     sizet nitems;
     SCM port;
{
  int ret;
  sizet i = PTOBNUM (port);
  SYSCALL (ret = (scm_ptobs[i].fwrite(ptr, size, nitems, STREAM (port))));
  if (scm_trans && (port == def_outp || port == cur_errp))
    SYSCALL (fwrite (ptr, size, nitems, scm_trans));
  return ret;
}

int 
scm_lgetc (port)
     SCM port;
{
  FILE *f;
  int c;
  sizet i;
  /* One char may be stored in the high bits of (car port) orre@nada.kth.se. */
  if (CRDYP (port))
    {
      c = CGETUN (port);
      CLRDY (port);		/* Clear ungetted char */
      return c;
    }
  f = STREAM (port);
  i = PTOBNUM (port);
#ifdef linux
  c = (scm_ptobs[i].fgetc) (f);
#else
  SYSCALL (c = (scm_ptobs[i].fgetc) (f));
#endif
  if (scm_trans && (f == stdin))
    SYSCALL (fputc (c, scm_trans));
  return c;
}

void 
scm_lungetc (c, port)
     int c;
     SCM port;
{
/*	ASSERT(!CRDYP(port), port, ARG2, "too many scm_lungetc");*/
  CUNGET (c, port);
}


static char s_read_char[] = "read-char";
SCM 
scm_read_char (port)
     SCM port;
{
  int c;
  if (UNBNDP (port))
 port = cur_inp;
  else
    ASSERT (NIMP (port) && OPINPORTP (port), port, ARG1, s_read_char);
  c = scm_lgetc (port);
  if (EOF == c)
    return EOF_VAL;
  return MAKICHR (c);
}

static char s_peek_char[] = "peek-char";
SCM 
scm_peek_char (port)
     SCM port;
{
  int c;
  if (UNBNDP (port))
    port = cur_inp;
  else
    ASSERT (NIMP (port) && OPINPORTP (port), port, ARG1, s_peek_char);
  c = scm_lgetc (port);
  if (EOF == c)
    return EOF_VAL;
  scm_lungetc (c, port);
  return MAKICHR (c);
}


char *
scm_grow_tok_buf (tok_buf)
     SCM tok_buf;
{
  sizet len = LENGTH (tok_buf);
  len += len / 2;
  scm_resizuve (tok_buf, (SCM) MAKINUM (len));
  return CHARS (tok_buf);
}

static char s_eofin[] = "end of file in ";
static int 
flush_ws (port, eoferr)
     SCM port;
     char *eoferr;
{
  register int c;
  while (1)
    switch (c = scm_lgetc (port))
      {
      case EOF:
      goteof:
	if (eoferr)
	  scm_wta (SCM_UNDEFINED, s_eofin, eoferr);
	return c;
      case ';':
      lp:
	switch (c = scm_lgetc (port))
	  {
	  case EOF:
	    goto goteof;
	  default:
	    goto lp;
	  case LINE_INCREMENTORS:
	    break;
	  }
      case LINE_INCREMENTORS:
	if (port==loadport) scm_linum++;
      case WHITE_SPACES:
	break;
      default:
	return c;
      }
}

#ifdef GUILE
static int default_case_i = 0;
#else 
static int default_case_i = 1;
#endif

char scm_s_read[] = "read";
SCM 
scm_lread (port, casep)
     SCM port;
     SCM casep;
{
  int c;
  SCM tok_buf;
  int case_i;

  if (UNBNDP (port))
    port = cur_inp;
  else
    ASSERT (NIMP (port) && OPINPORTP (port), port, ARG1, scm_s_read);

  case_i = (casep == UNSPECIFIED
	    ? default_case_i
	    : (casep == BOOL_F));

  do
    {
      c = flush_ws (port, (char *) NULL);
      if (EOF == c)
	return EOF_VAL;
      scm_lungetc (c, port);
      tok_buf = scm_makstr (30L, 0);
    }
  while (EOF_VAL == (tok_buf = lreadr (tok_buf, port, case_i)));
  return tok_buf;
}

static int
casei_streq (s1, s2)
     char * s1;
     char * s2;
{
  while (*s1 && *s2)
    if (scm_downcase[*s1] != scm_downcase[*s2])
      return 0;
    else
      {
	++s1;
	++s2;
      }
  return !(*s1 || *s2);
}


static char s_unknown_sharp[] = "unknown # object";
static SCM 
lreadr (tok_buf, port, case_i)
     SCM tok_buf;
     SCM port;
     int case_i;
{
  int c;
  sizet j;
  SCM p;
tryagain:
  c = flush_ws (port, scm_s_read);
  switch (c)
    {
/*	case EOF: return EOF_VAL;*/
#ifdef BRACKETS_AS_PARENS
    case '[':
#endif
    case '(':
      return lreadparen (tok_buf, port, scm_s_list, case_i);
#ifdef BRACKETS_AS_PARENS
    case ']':
#endif
    case ')':
      scm_warn ("unexpected \")\"", "");
      goto tryagain;
    case '\'':
      return scm_cons2 (scm_i_quote, lreadr (tok_buf, port, case_i), EOL);
    case '`':
      return scm_cons2 (scm_i_quasiquote, lreadr (tok_buf, port, case_i), EOL);
    case ',':
      c = scm_lgetc (port);
      if ('@' == c)
	p = scm_i_uq_splicing;
      else
	{
	  scm_lungetc (c, port);
	  p = scm_i_unquote;
	}
      return scm_cons2 (p, lreadr (tok_buf, port, case_i), EOL);
    case '#':
      c = scm_lgetc (port);
      switch (c)
	{
#ifdef BRACKETS_AS_PARENS
	case '[':
#endif
	case '(':
	  p = lreadparen (tok_buf, port, s_vector, case_i);
	  return NULLP (p) ? nullvect : scm_vector (p);
	case 't':
	case 'T':
	  return BOOL_T;
	case 'f':
	case 'F':
	  return BOOL_F;
	case 'b':
	case 'B':
	case 'o':
	case 'O':
	case 'd':
	case 'D':
	case 'x':
	case 'X':
	case 'i':
	case 'I':
	case 'e':
	case 'E':
	  scm_lungetc (c, port);
	  c = '#';
	  goto num;
	case '*':
	  j = read_token (c, tok_buf, port, case_i, 0);
	  p = scm_istr2bve (CHARS (tok_buf) + 1, (long) (j - 1));
	  if (NFALSEP (p))
	    return p;
	  else
	    goto unkshrp;
	case '{':
	  j = read_token (c, tok_buf, port, case_i, 1);
	  p = scm_intern (CHARS (tok_buf), j);
	  return CAR (p);
	case '\\':
	  c = scm_lgetc (port);
	  j = read_token (c, tok_buf, port, case_i, 0);
	  if (j == 1)
	    return MAKICHR (c);
	  if (c >= '0' && c < '8')
	    {
	      p = scm_istr2int (CHARS (tok_buf), (long) j, 8);
	      if (NFALSEP (p))
		return MAKICHR (INUM (p));
	    }
	  for (c = 0; c < sizeof scm_charnames / sizeof (char *); c++)
	    if (scm_charnames[c]
		&& (casei_streq (scm_charnames[c], CHARS (tok_buf))))
	      return MAKICHR (scm_charnums[c]);
	  scm_wta (SCM_UNDEFINED, "unknown # object: #\\", CHARS (tok_buf));
	case '|':
	  j = 1;		/* here j is the comment nesting depth */
	lp:c = scm_lgetc (port);
	lpc:switch (c)
	    {
	    case EOF:
	      scm_wta (SCM_UNDEFINED, s_eofin, "balanced comment");
	    case LINE_INCREMENTORS:
	      if (port==loadport) scm_linum++;
	    default:
	      goto lp;
	    case '|':
	      if ('#' != (c = scm_lgetc (port)))
		goto lpc;
	      if (--j)
		goto lp;
	      break;
	    case '#':
	      if ('|' != (c = scm_lgetc (port)))
		goto lpc;
	      ++j;
	      goto lp;
	    }
	  goto tryagain;
	case '.':
	  p = lreadr (tok_buf, port, case_i);
	  return scm_neval (p);
	default:
	callshrp:
	  p = CDR (scm_intern ("read:sharp", (sizeof "read:sharp") - 1));
	  if (NIMP (p))
	    {
	      p = scm_apply (p, MAKICHR (c), scm_acons (port, EOL, EOL));
	      if (UNSPECIFIED == p)
		goto tryagain;
	      return p;
	    }
	unkshrp:scm_wta ((SCM) MAKICHR (c), s_unknown_sharp, "");
	}
    case '\"':
      j = 0;
      while ('\"' != (c = scm_lgetc (port)))
	{
	  ASSERT (EOF != c, SCM_UNDEFINED, s_eofin, s_string);
	  if (j + 1 >= LENGTH (tok_buf))
	    scm_grow_tok_buf (tok_buf);
	  if (c == '\\')
	    switch (c = scm_lgetc (port))
	      {
	      case '\n':
		continue;
	      case '0':
		c = '\0';
		break;
	      case 'f':
		c = '\f';
		break;
	      case 'n':
		c = '\n';
		break;
	      case 'r':
		c = '\r';
		break;
	      case 't':
		c = '\t';
		break;
	      case 'a':
		c = '\007';
		break;
	      case 'v':
		c = '\v';
		break;
	      }
	  CHARS (tok_buf)[j] = c;
	  ++j;
	}
      if (j == 0)
	return nullstr;
      CHARS (tok_buf)[j] = 0;
      return scm_makfromstr (CHARS (tok_buf), j, 0);
    case DIGITS:
    case '.':
    case '-':
    case '+':
    num:
      j = read_token (c, tok_buf, port, case_i, 0);
      p = scm_istring2number (CHARS (tok_buf), (long) j, 10L);
      if (NFALSEP (p))
 return p;
      if (c == '#')
	{
	  if ((j == 2) && (scm_lgetc (port) == '('))
	    {
	      scm_lungetc ('(', port);
	      c = CHARS (tok_buf)[1];
	      goto callshrp;
	    }
	  scm_wta (SCM_UNDEFINED, s_unknown_sharp, CHARS (tok_buf));
	}
      goto tok;
    case ':':
      j = read_token ('-', tok_buf, port, case_i, 0);
      p = scm_intern (CHARS (tok_buf), j);
      return scm_make_kw (CAR (p));
    default:
      j = read_token (c, tok_buf, port, case_i, 0);
    tok:
      p = scm_intern (CHARS (tok_buf), j);
      return CAR (p);
    }
}

#ifdef _UNICOS
_Pragma ("noopt");		/* # pragma _CRI noopt */
#endif
static sizet 
read_token (ic, tok_buf, port, case_i, weird)
     int ic;
     SCM tok_buf;
     SCM port;
     int case_i;
     int weird;
{
  register sizet j;
  register int c;
  register char *p;

  c = ic;
  p = CHARS (tok_buf);

  if (!weird)
    {
      p[0] = (case_i ? scm_downcase[c] : c);
      j = 1;
    }
  else
    j = 0;

  while (1)
    {
      if (j + 1 >= LENGTH (tok_buf))
	p = scm_grow_tok_buf (tok_buf);
      c = scm_lgetc (port);
    dispatch:
      switch (c)
	{
#ifdef BRACKETS_AS_PARENS
	case '[':
	case ']':
#endif
	case '(':
	case ')':
	case '\"':
	case ';':
	case WHITE_SPACES:
	case LINE_INCREMENTORS:
	  if (weird)
	    goto default_case;

	  scm_lungetc (c, port);
	case EOF:
	eof_case:
	  p[j] = 0;
	  return j;
	case '\\':
	  if (!weird)
	    goto default_case;
	  else
	    {
	      c = scm_lgetc (port);
	      if (c == EOF)
		goto eof_case;
	      else
		goto default_case;
	    }
	case '}':
	  if (!weird)
	    goto default_case;

	  c = scm_lgetc (port);
	  if (c == '#')
	    {
	      p[j] = 0;
	      return j;
	    }
	  else
	    {
	      scm_lungetc (c, port);
	      c = '}';
	      goto default_case;
	    }

	default:
	default_case:
	  p[j++] = (case_i ? scm_downcase[c] : c);
	}
    }
}
#ifdef _UNICOS
_Pragma ("opt");		/* # pragma _CRI opt */
#endif

static SCM 
lreadparen (tok_buf, port, name, case_i)
     SCM tok_buf;
     SCM port;
     char *name;
     int case_i;
{
  SCM tmp, tl, ans;
  int c = flush_ws (port, name);
  if (')' == c
#ifdef BRACKETS_AS_PARENS
      || ']' == c
#endif
    )
    return EOL;
  scm_lungetc (c, port);
  if (scm_i_dot == (tmp = lreadr (tok_buf, port, case_i)))
    {
      ans = lreadr (tok_buf, port, case_i);
    closeit:
      if (')' != (c = flush_ws (port, name))
#ifdef BRACKETS_AS_PARENS
	  && ']' != c
#endif
	)
	scm_wta (SCM_UNDEFINED, "missing close paren", "");
      return ans;
    }
  ans = tl = scm_cons (tmp, EOL);
  while (')' != (c = flush_ws (port, name))
#ifdef BRACKETS_AS_PARENS
	 && ']' != c
#endif
    )
    {
      scm_lungetc (c, port);
      if (scm_i_dot == (tmp = lreadr (tok_buf, port, case_i)))
	{
	  CDR (tl) = lreadr (tok_buf, port, case_i);
	  goto closeit;
	}
      tl = (CDR (tl) = scm_cons (tmp, EOL));
    }
  return ans;
}

/* {Loading from source files.}
 */

static scm_cell scm_tmp_loadpath = {(SCM) BOOL_F, (SCM) EOL};
SCM *scm_loc_loadpath = (SCM *) & scm_tmp_loadpath;
SCM loadport = SCM_UNDEFINED;
long scm_linum = 1;


static char s_tryload[] = "try-load";
#define s_load (&s_tryload[4])

SCM 
scm_tryload (filename)
     SCM filename;
{
  ASSERT (NIMP (filename) && STRINGP (filename), filename, ARG1, s_load);
  {
    SCM oloadpath = *scm_loc_loadpath;
    SCM oloadport = loadport;
    long olninum = scm_linum;
    SCM form, port;
    port = scm_open_file (filename,
			  scm_makfromstr ("r", (sizet) sizeof (char), 0));
    if (FALSEP (port))
      return port;
    *scm_loc_loadpath = filename;
    loadport = port;
    scm_linum = 1;
    while (1)
      {
	form = scm_lread (port, UNSPECIFIED);
	if (EOF_VAL == form)
	  break;
	scm_neval (form);
      }
    scm_close_port (port);
    scm_linum = olninum;
    loadport = oloadport;
    *scm_loc_loadpath = oloadpath;
  }
  return BOOL_T;
}


/* {Errors and Exceptional Conditions}
 */


static SCM scm_err_exp;
static SCM scm_err_env;
static char * scm_err_pos;
static char * scm_err_s_subr;
static scm_cell scm_tmp_errobj = {(SCM) SCM_UNDEFINED, (SCM) EOL};
static SCM *scm_loc_errobj = (SCM *) & scm_tmp_errobj;

struct errdesc scm_errmsgs[] =
{
  {"Wrong number of args", 0, 0},
  {"numerical overflow", 0, FPE_SIGNAL},
  {"Argument out of range", 0, FPE_SIGNAL},
  {"Could not allocate", "out-of-storage", 0},
  {"EXIT", "end-of-program", -1},
  {"hang up", "hang-up", EXIT},
  {"user interrupt", "user-interrupt", 0},
  {"arithmetic error", "arithmetic-error", 0},
  {"bus error", 0, 0},
  {"segment violation", 0, 0},
  {"alarm", "alarm-interrupt", 0}
};

/* True only when errors indicate a bug in the
 * interpreter.
 */
int scm_errjmp_bad = 1;

/* True between DEFER_INTS and ALLOW_INTS, and
 * when the interpreter is not running at all.
 */
int scm_ints_disabled = 1;

/* Becomes true between DEFER_INTS and ALLOW_INTS if a
 * a signal occurs.  Cleared by ALLOW_INTS which handles
 * the signal.
 */
int scm_sig_deferred = 0;

/* Becomes true between DEFER_INTS and ALLOW_INTS if a
 * an alarm signal occurs.  Cleared by ALLOW_INTS which handles
 * the signal.
 */
int scm_alrm_deferred = 0;

void def_err_response P ((void));

/* Handle signal number I.
 * If a scheme handler is allowed for this signal,
 * and the user has defined one, call it and
 * return i.
 *
 * Otherwise, if there is a more basic signal whose
 * handler is applicable, return that signal number.
 * 
 * Otherwise return 0.
 */
static int 
scm_handle_it (i)
     int i;
{
  char *name;
  SCM proc;

  name = scm_errmsgs[i - WNA].s_response;
  if (scm_errjmp_bad) return -1;
  if (name)
    {
      NEWCELL(proc);		/* discard possibly-used cell */
      proc = CDR (scm_intern (name, (sizet) strlen (name)));
      if (NIMP (proc))
	{
	  scm_apply (proc, EOL, EOL);
	  return i;
	}
    }
  return scm_errmsgs[i - WNA].parent_err;
}

void 
scm_han_sig ()
{
  scm_sig_deferred = 0;
  if (INT_SIGNAL != scm_handle_it (INT_SIGNAL))
    scm_wta (SCM_UNDEFINED, (char *) INT_SIGNAL, "");
}

void 
scm_han_alrm ()
{
  scm_alrm_deferred = 0;
  if (ALRM_SIGNAL != scm_handle_it (ALRM_SIGNAL))
    scm_wta (SCM_UNDEFINED, (char *) ALRM_SIGNAL, "");
}

static void 
err_head (str)
     char *str;
{
  int oerrno = errno;
  scm_exitval = MAKINUM (EXIT_FAILURE);
  if (NIMP (cur_outp))
    scm_lfflush (cur_outp);
  scm_lputc ('\n', cur_errp);
  if (BOOL_F != *scm_loc_loadpath)
    {
      scm_iprin1 (*scm_loc_loadpath, cur_errp, 1);
      scm_lputs (", line ", cur_errp);
      scm_intprint ((long) scm_linum, 10, cur_errp);
      scm_lputs (": ", cur_errp);
    }
  scm_lfflush (cur_errp);
  errno = oerrno;
  if (cur_errp == def_errp)
    {
      if (errno > 0)
	perror (str);
      fflush (stderr);
      return;
    }
}

void 
scm_warn (str1, str2)
     char *str1, *str2;
{
  err_head ("WARNING");
  scm_lputs ("WARNING: ", cur_errp);
  scm_lputs (str1, cur_errp);
  scm_lputs (str2, cur_errp);
  scm_lputc ('\n', cur_errp);
  scm_lfflush (cur_errp);
}

static char s_errno[] = "errno";
static SCM 
scm_lerrno (arg)
     SCM arg;
{
  int old = errno;
  if (!UNBNDP (arg))
    {
      if (FALSEP (arg))
	errno = 0;
      else
	errno = INUM (arg);
    }
  return MAKINUM (old);
}

static char s_perror[] = "perror";
static SCM 
scm_lperror (arg)
     SCM arg;
{
  ASSERT (NIMP (arg) && STRINGP (arg), arg, ARG1, s_perror);
  err_head (CHARS (arg));
  return UNSPECIFIED;
}

void 
def_err_response ()
{
  SCM obj = *scm_loc_errobj;
  DEFER_INTS;
  err_head ("ERROR");
  scm_lputs ("ERROR: ", cur_errp);
  if (scm_err_s_subr && *scm_err_s_subr)
    {
      scm_lputs (scm_err_s_subr, cur_errp);
      scm_lputs (": ", cur_errp);
    }
  if (scm_err_pos == (char *) ARG1 && UNBNDP (*scm_loc_errobj))
    scm_err_pos = (char *) WNA;
#ifdef nosve
  if ((~0x1fL) & (short) scm_err_pos)
    scm_lputs (scm_err_pos, cur_errp);
  else if (WNA > (short) scm_err_pos)
    {
      scm_lputs ("Wrong type in arg", cur_errp);
      scm_lputc('0'+(int)scm_err_pos, cur_errp);
    }
#else
  if ((~0x1fL) & (long) scm_err_pos)
    scm_lputs (scm_err_pos, cur_errp);
  else if (WNA > (long) scm_err_pos)
    {
      scm_lputs ("Wrong type in arg", cur_errp);
      scm_lputc(scm_err_pos ? '0'+(int)scm_err_pos : ' ', cur_errp);
    }
#endif
  else
    {
      scm_lputs (scm_errmsgs[((int) scm_err_pos) - WNA].msg, cur_errp);
      goto outobj;
    }
  if (IMP (obj) || SYMBOLP (obj) || (TYP16 (obj) == tc7_port)
      || (NFALSEP (scm_procedurep (obj))) || (NFALSEP (scm_numberp (obj))))
    {
    outobj:
      if (!UNBNDP (obj))
	{
	  scm_lputs (((long) scm_err_pos == WNA) ? " to " : " ", cur_errp);
	  scm_iprin1 (obj, cur_errp, 1);
	}
    }
  else
    scm_lputs (" (see errobj)", cur_errp);
  if (UNBNDP (scm_err_exp))
    goto getout;
  if (NIMP (scm_err_exp))
    {
      scm_lputs ("\n; in expression: ", cur_errp);
      if (NCONSP (scm_err_exp))
	scm_iprin1 (scm_err_exp, cur_errp, 1);
      else if (SCM_UNDEFINED == CDR (scm_err_exp))
	scm_iprin1 (CAR (scm_err_exp), cur_errp, 1);
      else
	scm_iprlist ("(... ", scm_err_exp, ')', cur_errp, 1);
    }
  if (NULLP (scm_err_env) || (BOOL_T == scm_procedurep (CAR (scm_err_env))))
    scm_lputs ("\n; in top level environment.", cur_errp);
  else
    {
      SCM env = scm_err_env;
      scm_lputs ("\n; in scope:", cur_errp);
      while (NNULLP (env) && (BOOL_T != scm_procedurep (CAR(env))))
	{
	  scm_lputc ('\n', cur_errp);
	  scm_lputs (";   ", cur_errp);
	  scm_iprin1 (CAR (CAR (env)), cur_errp, 1);
	  env = CDR (env);
	}
    }
getout:
  scm_lputc ('\n', cur_errp);
  scm_lfflush (cur_errp);
  scm_err_exp = scm_err_env = SCM_UNDEFINED;
  if (scm_errjmp_bad)
    {
      scm_iprin1 (obj, cur_errp, 1);
      scm_lputs ("\nFATAL ERROR DURING CRITICAL CODE SECTION\n", cur_errp);
#ifdef vms
      exit(EXIT_FAILURE);
#else
      exit(errno? (long)errno : EXIT_FAILURE);
#endif
    }
  errno = 0;
  ALLOW_INTS;
}


static SCM system_error_sym;

void 
scm_everr (exp, env, arg, pos, s_subr)
     SCM exp, env, arg;
     char *pos, *s_subr;
{

  /* Give preference to a user supplied error
   * handler.
   */
  {
    SCM desc;
    SCM args;

    if ((~0x1fL) & (long) pos)
      {
	desc = makfrom0str (pos);
      }
    else
      desc = MAKINUM ((long)pos);

    {
      SCM sym;
      if (!s_subr || !*s_subr)
	sym = BOOL_F;
      else
	sym = CAR (scm_intern0 (s_subr));
      args = scm_listify (desc, sym, arg, SCM_UNDEFINED);
    }

    /* (throw (quote system-error) <desc> <proc-name> arg)
     *
     * <desc> is a string or an integer (see %%system-errors).
     * <proc-name> is a symbol or #f in some annoying cases (e.g. cddr).
     */

    _scm_throw (system_error_sym, args, 0);

    /* The call to throw might return if no handler can
     * be found.
     */
  }
  
  /* Handle the error at the current root continuation. */
  scm_err_exp = exp;
  scm_err_env = env;
  *scm_loc_errobj = arg;
  scm_err_pos = pos;
  scm_err_s_subr = s_subr;
  if (   ((~0x1fL) & (long) pos)
      || (WNA > (long) pos)
      || NIMP(dynwinds)
      || scm_errjmp_bad)
    {
      def_err_response ();
      scm_abrt ();
    }
  if (scm_errjmp_bad)
    exit (INUM (scm_exitval));
  scm_dowinds (EOL, scm_ilength (dynwinds));
  longjmp (JMPBUF (rootcont), (int) pos);
  /* Error processing is done at the stack base. */
}

void 
scm_wta (arg, pos, s_subr)
     SCM arg;
     char *pos, *s_subr;
{
  scm_everr (SCM_UNDEFINED, EOL, arg, pos, s_subr);
}


/* {Way Out}
 */

SCM 
scm_quit (n)
     SCM n;
{
  if (UNBNDP (n) || BOOL_T == n)
    n = MAKINUM (EXIT_SUCCESS);
  else if (INUMP (n))
    scm_exitval = n;
  else
    scm_exitval = MAKINUM (EXIT_FAILURE);
  if (scm_errjmp_bad)
    exit (INUM (scm_exitval));
  scm_dowinds (EOL, scm_ilength (dynwinds));
  longjmp (JMPBUF (rootcont), -1);
}

static char s_abrt[] = "abort";
SCM 
scm_abrt ()
{
  if (scm_errjmp_bad)
    exit (INUM (scm_exitval));
  scm_dowinds (EOL, scm_ilength (dynwinds));
  longjmp (JMPBUF (rootcont), -2);
}

static char s_restart[] = "restart";
SCM 
scm_restart ()
{
  scm_dowinds (EOL, scm_ilength (dynwinds));
  longjmp (JMPBUF (rootcont), -3);
}


/* {call-with-dynamic-root}
 *
 * Suspending the current thread to evaluate a thunk on the
 * same C stack but in a new dynamic context.
 *
 * Calls to call-with-dynamic-root return exactly once (unless
 * the process is somehow exitted).
 */

SCM scm_exitval;		/* INUM with return value */
static int n_dynamic_roots = 0;

static SCM 
_cwdr (thunk, a1, args, error_thunk, stack_start)
     SCM thunk;
     SCM a1;
     SCM args;
     SCM error_thunk;
     STACKITEM * stack_start;
{
#ifdef _UNICOS
  int i;
#else
  long i;
#endif

  SCM inferior_exitval;		/* INUM with return value */
  SCM old_dynamic_winds;
  SCM old_rootcont;
  SCM answer;

  /* Exit the caller's dynamic state. 
   */
  old_dynamic_winds = dynwinds;
  scm_dowinds (EOL, scm_ilength (dynwinds));

  /* Create a fresh root continuation.
   * Temporarily substitute it for the native root continuation.
   */
  old_rootcont = rootcont;
  {
    SCM new_root;
    NEWCELL (new_root);
    DEFER_INTS;
    SETJMPBUF (new_root,
	       scm_must_malloc ((long) sizeof (regs),
				"inferior root continuation"));
    CAR (new_root) = tc7_contin;
    DYNENV (new_root) = EOL;
    BASE (new_root) = stack_start;
    SEQ (new_root) = n_dynamic_roots++;
    ALLOW_INTS;
    rootcont = new_root;
  }


  /* Establish a jump-buffer for returns to this dynamic root.
   */
  i = setjmp (JMPBUF (rootcont));

  switch ((int) i)
    {
    default:
      {
	/* An error condition.
	 */
	char *name = scm_errmsgs[i - WNA].s_response;
	if (name)
	  {
	    SCM proc = CDR (scm_intern (name, (sizet) strlen (name)));
	    if (NIMP (proc))
	      scm_apply (proc, EOL, EOL);
	  }
	if ((i = scm_errmsgs[i - WNA].parent_err))
	  goto error_exit;
	def_err_response ();
	scm_errjmp_bad = 0;
	scm_alrm_deferred = 0;
	scm_sig_deferred = 0;
	scm_ints_disabled = 0;
	goto error_exit;
      }

    case 0:
      inferior_exitval = MAKINUM (EXIT_SUCCESS);
      scm_errjmp_bad = 0;
      errno = 0;
      scm_alrm_deferred = 0;
      scm_sig_deferred = 0;
      scm_ints_disabled = 0;
      scm_errjmp_bad = 0;
      scm_alrm_deferred = 0;
      scm_sig_deferred = 0;
      scm_ints_disabled = 0;
      *scm_loc_loadpath = BOOL_F;
      answer = scm_apply (thunk, a1, args);
      goto return_answer;

    case -2:
      /* (...fallthrough)
       *
       * Inferior executed (abort).
       *
       */
      scm_errjmp_bad = 0;
      scm_alrm_deferred = 0;
      scm_sig_deferred = 0;
      scm_ints_disabled = 0;
      /*
       * (...fallthrough)
       */
    case -1:
      /* 
       * Inferior executed (quit).
       *
       * (...fallthrough)
       */
    case -3:
      /* (...fallthrough)
       *
       * Inferior executed (restart).
       *
       * (...fallthrough)
       */
    error_exit:
      /*
       *
       * Inferior caused an error.
       *
       */
      *scm_loc_loadpath = BOOL_F;
      answer = scm_apply (error_thunk, scm_cons (MAKINUM (i), EOL), EOL);
      rootcont = old_rootcont;
      scm_dowinds (old_dynamic_winds,   - scm_ilength (old_dynamic_winds));
      return answer;
    }

 return_answer:
  rootcont = old_rootcont;
  scm_dowinds (old_dynamic_winds,   - scm_ilength (old_dynamic_winds));
  return answer;
}

static char s_cwdr[] = "with-dynamic-root";
SCM
scm_cwdr (thunk, error_thunk)
     SCM thunk;
     SCM error_thunk;
{
  STACKITEM stack_place;

  return _cwdr (thunk, EOL, EOL, error_thunk, &stack_place);
}

SCM
scm_app_wdr (proc, a1, args, error)
     SCM proc;
     SCM a1;
     SCM args;
     SCM error;
{
  STACKITEM stack_place;
  return _cwdr (proc, a1, args, error, &stack_place);
}



/* {Read-eval-print Loops}
 */

int scm_verbose = 1;
long scm_cells_allocated = 0;
long scm_lcells_allocated = 0;
long scm_mallocated = 0;
long scm_lmallocated = 0;
long scm_rt = 0;
long scm_gc_rt;
long scm_gc_time_taken;
long scm_gc_cells_collected;
long scm_gc_malloc_collected;
long scm_gc_ports_collected;


int scm_ldfile(path)
     char *path;
{
  SCM name = scm_makfromstr(path, (sizet)(strlen(path))*sizeof(char), 0);
  *scm_loc_errobj = name;
  return BOOL_F==scm_tryload(name);
}
int scm_ldprog(path)
     char *path;
{
  SCM name = scm_makfromstr(path, (sizet)(strlen(path))*sizeof(char), 0);
  *scm_loc_errobj = name;
  return
    BOOL_F==scm_evstr("(try-load (in-vicinity (program-vicinity) errobj))");
}
static char s_eval_string[] = "eval-string";
static char s_load_string[] = "load-string";
SCM scm_eval_string(str)
     SCM str;
{
  str = scm_mkstrport(INUM0, str, OPN | RDNG, s_eval_string);
  str = scm_lread(str, default_case_i);
  return EVAL(str, (SCM)EOL);
}
SCM scm_evstr(str)
     char *str;
{
  SCM lsym;
  NEWCELL(lsym);
  SETLENGTH(lsym, strlen(str)+0L, tc7_ssymbol);
  SETCHARS(lsym, str);
  return scm_eval_string(lsym);
}
SCM scm_load_string(str)
     SCM str;
{
  ASSERT(NIMP(str) && (STRINGP(str) || SYMBOLP(str)), str, ARG1,
	 s_load_string);
  str = scm_mkstrport(INUM0, str, OPN | RDNG, s_load_string);
  while(1) {
    SCM form = scm_lread(str, default_case_i);
    if (EOF_VAL==form) break;
    SIDEVAL(form, EOL);
  }
  return BOOL_T;
}
void scm_ldstr(str)
     char *str;
{
  SCM lsym;
  NEWCELL(lsym);
  SETLENGTH(lsym, strlen(str)+0L, tc7_ssymbol);
  SETCHARS(lsym, str);
  scm_load_string(lsym);
}

SCM scm_exitval;		/* INUM with return value */
SCM 
scm_repl_driver (initpath)
     char *initpath;
{
#ifdef _UNICOS
  int i;
#else
  long i;
#endif
  BASE (rootcont) = (STACKITEM *) & i;
  SEQ (rootcont) = n_dynamic_roots++;
  i = setjmp (JMPBUF (rootcont));
drloop:
  switch ((int) i)
    {
    default:
      {
	char *name = scm_errmsgs[i - WNA].s_response;
	if (name)
	  {
	    SCM proc = CDR (scm_intern (name, (sizet) strlen (name)));
	    if (NIMP (proc))
	      scm_apply (proc, EOL, EOL);
	  }
	if ((i = scm_errmsgs[i - WNA].parent_err))
	  goto drloop;
	def_err_response ();
	goto reset_toplvl;
      }
    case 0:
      scm_exitval = MAKINUM (EXIT_SUCCESS);
      scm_errjmp_bad = 0;
      errno = 0;
      scm_alrm_deferred = 0;
      scm_sig_deferred = 0;
      scm_ints_disabled = 0;
      if (scm_ldfile(initpath))	/* load Scheme init files */
	scm_wta(*scm_loc_errobj, "Could not open file", s_load); /*  */
    case -2:
    reset_toplvl:
      scm_errjmp_bad = 0;
      scm_alrm_deferred = 0;
      scm_sig_deferred = 0;
      scm_ints_disabled = 0;
      /* need to close loading files here. */
      *scm_loc_loadpath = BOOL_F;
      loadport = SCM_UNDEFINED;
      scm_repl (scm_makfromstr (PROMPT, strlen (PROMPT), 0), BOOL_F);
      scm_err_pos = (char *) EXIT;
      i = EXIT;
      goto drloop;		/* encountered EOF on stdin */
    case -1:
      return scm_exitval;
    case -3:
      return 0;
    }
}

SCM 
scm_line_num ()
{
  return MAKINUM (scm_linum);
}
SCM 
scm_prog_args ()
{
  return progargs;
}

extern char scm_s_heap[];
extern CELLPTR *scm_hplims;
void 
scm_growth_mon (obj, size, units)
     char *obj;
     long size;
     char *units;
{
  if (scm_verbose > 2)
    {
      scm_lputs ("; grew ", cur_errp);
      scm_lputs (obj, cur_errp);
      scm_lputs (" to ", cur_errp);
      scm_intprint (size, 10, cur_errp);
      scm_lputc (' ', cur_errp);
      scm_lputs (units, cur_errp);
      if ((scm_verbose > 4) && (obj == scm_s_heap))
	scm_heap_report ();
      scm_lputs ("\n", cur_errp);
    }
}

void 
scm_gc_start (what)
     char *what;
{
  if (scm_verbose > 3 && FPORTP (cur_errp))
    {
      ALLOW_INTS;
      scm_lputs (";GC(", cur_errp);
      scm_lputs (what, cur_errp);
      scm_lputs (")", cur_errp);
      scm_lfflush (cur_errp);
      DEFER_INTS;
    }
  scm_gc_rt = INUM (scm_my_time ());
  scm_gc_cells_collected = 0;
  scm_gc_malloc_collected = 0;
  scm_gc_ports_collected = 0;
}

void 
scm_gc_end ()
{
  scm_gc_rt = INUM (scm_my_time ()) - scm_gc_rt;
  scm_gc_time_taken = scm_gc_time_taken + scm_gc_rt;
  if (scm_verbose > 3)
    {
      ALLOW_INTS;
      if (!FPORTP (cur_errp))
	scm_lputs (";GC ", cur_errp);
      scm_intprint (scm_time_in_msec (scm_gc_rt), 10, cur_errp);
      scm_lputs (" cpu mSec, ", cur_errp);
      scm_intprint (scm_gc_cells_collected, 10, cur_errp);
      scm_lputs (" cells, ", cur_errp);
      scm_intprint (scm_gc_malloc_collected, 10, cur_errp);
      scm_lputs (" malloc, ", cur_errp);
      scm_intprint (scm_gc_ports_collected, 10, cur_errp);
      scm_lputs (" ports collected\n", cur_errp);
      scm_lfflush (cur_errp);
      DEFER_INTS;
    }
}

void 

scm_repl_report ()
{
  if (scm_verbose > 1)
    {
      scm_lfflush (cur_outp);
      scm_lputs (";Evaluation took ", cur_errp);
      scm_intprint (scm_time_in_msec (INUM (scm_my_time ()) - scm_rt), 10, cur_errp);
      scm_lputs (" mSec (", cur_errp);
      scm_intprint (scm_time_in_msec (scm_gc_time_taken), 10, cur_errp);
      scm_lputs (" in scm_gc) ", cur_errp);
      scm_intprint (scm_cells_allocated - scm_lcells_allocated, 10, cur_errp);
      scm_lputs (" cells work, ", cur_errp);
      scm_intprint (scm_mallocated - scm_lmallocated, 10, cur_errp);
      scm_lputs (" bytes other\n", cur_errp);
      scm_lfflush (cur_errp);
    }
}

SCM 
scm_lroom (args)
     SCM args;
{
  scm_intprint (scm_cells_allocated, 10, cur_errp);
  scm_lputs (" out of ", cur_errp);
  scm_intprint (scm_heap_size, 10, cur_errp);
  scm_lputs (" cells in use, ", cur_errp);
  scm_intprint (scm_mallocated, 10, cur_errp);
  scm_lputs (" bytes allocated (of ", cur_errp);
  scm_intprint (scm_mtrigger, 10, cur_errp);
  scm_lputs (")\n", cur_errp);
  if (NIMP (args))

    {
      scm_heap_report ();
      scm_lputs ("\n", cur_errp);
      scm_stack_report ();
    }
  return UNSPECIFIED;
}

extern int scm_n_heap_segs;
void 
scm_heap_report ()
{
  sizet i = 0;
  scm_lputs ("; heap segments:", cur_errp);
  while (i < scm_n_heap_segs)
    {
      scm_lputs ("\n; 0x", cur_errp);
      scm_intprint ((long) scm_heap_table[i].bounds[0], 16, cur_errp);
      scm_lputs (" - 0x", cur_errp);
      scm_intprint ((long) scm_heap_table[i].bounds[1], 16, cur_errp);
      ++i;
    }
}

void 
scm_exit_report ()
{
  if (scm_verbose > 2)
    {
      scm_lputs (";Totals: ", cur_errp);
      scm_intprint (scm_time_in_msec (INUM (scm_my_time ())), 10, cur_errp);
      scm_lputs (" mSec my time, ", cur_errp);
      scm_intprint (scm_time_in_msec (INUM (scm_your_time ())), 10, cur_errp);
      scm_lputs (" mSec your time\n", cur_errp);
    }
}

static char s_verbose[]="verbose";
SCM 
scm_prolixity (arg)
     SCM arg;
{
  int old = scm_verbose;
  if (!UNBNDP (arg))
    {
      if (FALSEP (arg))
	scm_verbose = 1;
      else
	scm_verbose = INUM (arg);
    }
  return MAKINUM (old);
}

static char s_repl[] = "repl";
SCM
scm_repl (prompt, env)
     SCM prompt;
     SCM env;
{
  SCM x;
  SCM answer;
  scm_repl_report ();
  answer = BOOL_F;
  while (1)
    {
      if (OPOUTPORTP (cur_inp))

	{			/* This case for curses window */
	  scm_lfflush (cur_outp);
	  if (scm_verbose)
	    scm_lputs (CHARS (prompt), cur_inp);
	  scm_lfflush (cur_inp);
	}
      else
	{
	  if (scm_verbose >= 0)
	    scm_lputs (CHARS (prompt), cur_outp);
	  scm_lfflush (cur_outp);
	}
      scm_lcells_allocated = scm_cells_allocated;
      scm_lmallocated = scm_mallocated;
      x = scm_lread (cur_inp, UNSPECIFIED);
      scm_rt = INUM (scm_my_time ());
      scm_gc_time_taken = 0;
      if (EOF_VAL == x)
	break;
      if (!CRDYP (cur_inp))	/* assure scm_newline read (and transcripted) */
	scm_lungetc (scm_lgetc (cur_inp), cur_inp);
#ifdef __TURBOC__
      if ('\n' != CGETUN (cur_inp))
	if (OPOUTPORTP (cur_inp))
		/* This case for curses window */
	  {
	    scm_lfflush (cur_outp);
	    scm_newline (cur_inp);
	  }
	else
	  scm_newline (cur_outp);
#endif
      {
	SCM top_env;
	top_env = (env == BOOL_F
		   ? scm_top_level_env (CDR (scm_top_level_lookup_thunk_var))
		   : env);
	answer = x = scm_eval_3 (x, 0, top_env);
      }
      scm_repl_report ();
      if (scm_verbose >= 0)
	{
	  scm_iprin1 (x, cur_outp, 1);
	  scm_lputc ('\n', cur_outp);
	}
    }
  return answer;
}

/* {Standard Ports}
 */
SCM 
scm_cur_input_port ()
{
  return cur_inp;
}

SCM 
scm_cur_output_port ()
{
  return cur_outp;
}

SCM 
scm_cur_error_port ()
{
  return cur_errp;
}

static char scm_s_cur_inp[] = "set-current-input-port";
SCM 
scm_set_inp (port)
     SCM port;
{
  SCM oinp = cur_inp;
  ASSERT (NIMP (port) && OPINPORTP (port), port, ARG1, scm_s_cur_inp);
  cur_inp = port;
  return oinp;
}

static char scm_s_cur_outp[] = "set-current-output-port";
SCM 
scm_set_outp (port)
     SCM port;
{
  SCM ooutp = cur_outp;
  ASSERT (NIMP (port) && OPOUTPORTP (port), port, ARG1, scm_s_cur_outp);
  cur_outp = port;
  return ooutp;
}

static char scm_s_cur_errp[] = "set-current-error-port";
SCM 
scm_set_errp (port)
     SCM port;
{
  SCM oerrp = cur_errp;
  ASSERT (NIMP (port) && OPOUTPORTP (port), port, ARG1, scm_s_cur_errp);
  cur_errp = port;
  return oerrp;
}

/* {Help finding slib}
 */

static char s_compiled_library_path[]="compiled-library-path";

static SCM
compiled_library_path ()
{
#ifndef LIBRARY_PATH
  return BOOL_F;
#else
  return makfrom0str (LIBRARY_PATH);
#endif
}



/* {Initializing the Module}
 */

static scm_iproc subr0s[] =
{
  { &scm_s_cur_inp[4], scm_cur_input_port },
  { &scm_s_cur_outp[4], scm_cur_output_port },
  { &scm_s_cur_errp[4], scm_cur_error_port },
  { "transcript-off", scm_trans_off },
  { "program-arguments", scm_prog_args },
  { "line-number", scm_line_num },
  { s_abrt, scm_abrt },
  { s_compiled_library_path, compiled_library_path },
/* dumps core!  { s_restart, scm_restart }, */
  { 0, 0 }
};

static scm_iproc subr1s[] =
{
  { scm_s_cur_inp, scm_set_inp },
  { scm_s_cur_outp, scm_set_outp },
  { scm_s_cur_errp, scm_set_errp },
  { "transcript-on", scm_trans_on },
  { s_tryload, scm_tryload },
  {s_load_string, scm_load_string},
  {s_eval_string, scm_eval_string},
  { s_perror, scm_lperror },
  { 0, 0 }
};

static scm_iproc subr1os[] =
{
  { s_read_char, scm_read_char },
  { s_peek_char, scm_peek_char },
  { scm_s_newline, scm_newline },
  { s_flush, scm_lflush },
#ifndef GO32
  { s_char_readyp, scm_char_readyp },
#endif
  { "quit", scm_quit },
  { s_verbose, scm_prolixity },
  { s_errno, scm_lerrno },
  { 0, 0 }
};

static scm_iproc subr2s[] =
{
  { s_cwdr, scm_cwdr },
  { s_repl, scm_repl },
  { 0, 0 }
};

static scm_iproc subr2os[] =
{
  { scm_s_read, scm_lread },
  { scm_s_write, scm_lwrite },
  { s_display, scm_display },
  { s_write_char, scm_write_char },
  { 0, 0 }
};

char scm_s_ccl[] = "char-code-limit";

void scm_init_repl (iverbose)
     int iverbose;
{
  scm_sysintern (scm_s_ccl, MAKINUM (CHAR_CODE_LIMIT));
  scm_loc_errobj = &CDR (scm_sysintern ("errobj", SCM_UNDEFINED));
  scm_loc_loadpath = &CDR (scm_sysintern ("*load-pathname*", BOOL_F));
  transcript = BOOL_F;
  scm_trans = 0;
  scm_linum = 1;
  scm_verbose = iverbose;
  scm_init_iprocs (subr0s, tc7_subr_0);
  scm_init_iprocs (subr1os, tc7_subr_1o);
  scm_init_iprocs (subr1s, tc7_subr_1);
  scm_init_iprocs (subr2s, tc7_subr_2);
  scm_init_iprocs (subr2os, tc7_subr_2o);
  scm_make_subr ("room", tc7_lsubr, scm_lroom);
#ifndef GO32
  scm_add_feature(s_char_readyp);
#endif
#ifdef ARM_ULIB
  set_erase ();
#endif

  system_error_sym = CAR (scm_intern0 ("%%system-error"));
  scm_permenant_object (system_error_sym);
}

void scm_final_repl ()
{
  scm_loc_errobj = (SCM *) & scm_tmp_errobj;
  scm_loc_loadpath = (SCM *) & scm_tmp_loadpath;
  loadport = SCM_UNDEFINED;
  transcript = BOOL_F;
  scm_trans = 0;
  scm_linum = 1;
}
