/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1997, 1998 Free Software Foundation, Inc.
 * 
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2, or (at your option)
 * any later version.
 * 
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 * 
 * You should have received a copy of the GNU General Public License
 * along with this software; see the file COPYING.  If not, write to
 * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
 *
 * As a special exception, the Free Software Foundation gives permission
 * for additional uses of the text contained in its release of GUILE.
 *
 * The exception is that, if you link the GUILE library with other files
 * to produce an executable, this does not by itself cause the
 * resulting executable to be covered by the GNU General Public License.
 * Your use of that executable is in no way restricted on account of
 * linking the GUILE library code into it.
 *
 * This exception does not however invalidate any other reasons why
 * the executable file might be covered by the GNU General Public License.
 *
 * This exception applies only to the code released by the
 * Free Software Foundation under the name GUILE.  If you copy
 * code from other Free Software Foundation releases into a copy of
 * GUILE, as the General Public License permits, the exception does
 * not apply to the code that you add in this way.  To avoid misleading
 * anyone as to the status of such modified files, you must delete
 * this exception notice from them.
 *
 * If you write modifications of your own for GUILE, it is your choice
 * whether to permit this exception to apply to your modifications.
 * If you do not wish that, delete this exception notice.  
 */

/* "repl.c" error, read-eval-print loop, read, write and load code.
   Author: Aubrey Jaffer */

#include "scm.h"
#include "setjump.h"
void	igc P((char *what, STACKITEM *stackbase));
void	unexec P((char *new_name, char *a_name, unsigned data_start,
		  unsigned bss_start, unsigned entry_address));

#ifdef ARM_ULIB
# include <termio.h>
int set_erase()
{
   struct termio tin;

   ioctl(0, TCGETA, &tin);
   tin.c_cc[VERASE] = '\010';

   ioctl(0, TCSETA,&tin);
   return(0);
}
#endif

unsigned char upcase[CHAR_CODE_LIMIT];
unsigned char downcase[CHAR_CODE_LIMIT];
unsigned char lowers[] = "abcdefghijklmnopqrstuvwxyz";
unsigned char uppers[] = "ABCDEFGHIJKLMNOPQRSTUVWXYZ";
void init_tables()
{
  int i;
  for(i = 0;i<CHAR_CODE_LIMIT;i++) upcase[i] = downcase[i] = i;
  for(i = 0;i<sizeof lowers/sizeof(char);i++) {
    upcase[lowers[i]] = uppers[i];
    downcase[uppers[i]] = lowers[i];
  }
  scm_verbose = 1;		/* Here so that monitor info won't be */
				/* printed while in init_storage. (BOOM) */
}

#ifdef EBCDIC
char *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", s_newline, "tab", "backspace", "return", "page", "null"};
char 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 *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", s_newline, "tab", "backspace", "return", "page", "null", "del"};
char 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 */
char *isymnames[] = {
				/* Special Forms */
				/*  NUM_ISPCSYMS ISPCSYMS here */
  "#@and", "#@begin", "#@case", "#@cond", "#@do", "#@if", "#@lambda",
  "#@let", "#@let*", "#@letrec", "#@or", "#@quote", "#@set!",
  "#@define", "#@apply", "#@farloc-car", "#@farloc-cdr", "#@delay",
  "#@quasiquote", "#@unquote", "#@unquote-splicing", "#@else", "#@=>",
				/* user visible ISYMS */
				/* other keywords */
				/* Flags */
  "#f", "#t", "#<undefined>", "#<eof>", "()", "#<unspecified>"
  };

static char	s_read_char[] = "read-char", s_peek_char[] = "peek-char";
char	s_read[] = "read", s_write[] = "write", s_newline[] = "newline";
static char	s_display[] = "display", s_write_char[] = "write-char";

static char	s_eofin[] = "end of file in ";
static char	s_unknown_sharp[] = "unknown # object";

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

void intprint(n, radix, port)
     long n;
     int radix;
     SCM port;
{
  char num_buf[INTBUFLEN];
  lfwrite(num_buf, (sizet)sizeof(char), iint2str(n, radix, num_buf), port);
}

void ipruk(hdr, ptr, port)
     char *hdr;
     SCM ptr;
     SCM port;
{
  lputs("#<unknown-", port);
  lputs(hdr, port);
  if (scm_cell_p(ptr)) {
    lputs(" (0x", port);
    intprint(CAR(ptr), -16, port);
    lputs(" . 0x", port);
    intprint(CDR(ptr), -16, port);
    lputs(") @", port);
  }
  lputs(" 0x", port);
  intprint(ptr, -16, port);
  lputc('>', port);
}

void iprlist(hdr, exp, tlr, port, writing)
     char *hdr, tlr;
     SCM exp;
     SCM port;
     int writing;
{
  lputs(hdr, port);
  /* CHECK_INTS; */
  iprin1(CAR(exp), port, writing);
  exp = GCCDR(exp); /* CDR(exp); */
  for(;NIMP(exp);exp = GCCDR(exp) /* CDR(exp)*/) {
    if (!scm_cell_p(~1L & exp)) break;
    if NECONSP(exp) break;
    lputc(' ', port);
    /* CHECK_INTS; */
    iprin1(CAR(exp), port, writing);
  }
  if NNULLP(exp) {
    lputs(" . ", port);
    iprin1(exp, port, writing);
  }
  lputc(tlr, port);
}
void iprin1(exp, port, writing)
     SCM exp;
     SCM port;
int writing;
{
  register long i;
taloop:
  switch (7 & (int)exp) {
  case 2:
  case 6:
    intprint(INUM(exp), 10, port);
    break;
  case 4:
    if ICHRP(exp) {
      i = ICHR(exp);
      if (writing) lputs("#\\", port);
      if (!writing) lputc((int)i, port);
      else if ((i <= ' ') && charnames[i]) lputs(charnames[i], port);
#ifndef EBCDIC
      else if (i=='\177')
	lputs(charnames[(sizeof charnames/sizeof(char *))-1], port);
#endif /* ndef EBCDIC */
      else if (i > '\177')
	intprint(i, -8, port);
      else lputc((int)i, port);
    }
    else if (IFLAGP(exp) && (ISYMNUM(exp)<(sizeof isymnames/sizeof(char *))))
      lputs(ISYMCHARS(exp), port);
    else if ILOCP(exp) {
      lputs("#@", port);
      intprint((long)IFRAME(exp), -10, port);
      lputc(ICDRP(exp)?'-':'+', port);
      intprint((long)IDIST(exp), -10, port);
    }
    else goto idef;
    break;
  case 1:			/* gloc */
    if (!scm_cell_p(exp-1)) {
      ipruk("gloc", exp, port);
      break;
    }
    lputs("#@", port);
    exp = CAR(exp-1);
    goto taloop;
  default:
  idef:
    ipruk("immediate", exp, port);
    break;
  case 0:
    if (!scm_cell_p(exp)) {
      ipruk("heap", exp, port);
      break;
    }
    switch TYP7(exp) {
    case tcs_cons_gloc:
    case tcs_cons_imcar:
    case tcs_cons_nimcar:
      iprlist("(", exp, ')', port, writing);
      break;
    case tcs_closures:
      exp = CODE(exp);
      iprlist("#<CLOSURE ", exp, '>', port, writing);
      break;
    case tc7_string:
      if (writing) {
	lputc('\"', port);
	for(i = 0;i<LENGTH(exp);++i) switch (CHARS(exp)[i]) {
	case '\"':
	case '\\':
	  lputc('\\', port);
	default:
	  lputc(CHARS(exp)[i], port);
	}
	lputc('\"', port);
	break;
      }
    case tcs_symbols:
      lfwrite(CHARS(exp), (sizet)sizeof(char), (sizet)LENGTH(exp), port);
      break;
    case tc7_vector:
      lputs("#(", port);
      for(i = 0;i+1<LENGTH(exp);++i) {
	/* CHECK_INTS; */
	iprin1(VELTS(exp)[i], port, writing);
	lputc(' ', port);
      }
      if (i<LENGTH(exp)) {
	/* CHECK_INTS; */
	iprin1(VELTS(exp)[i], port, writing);
      }
      lputc(')', port);
      break;
    case tc7_bvect:
    case tc7_ivect:
    case tc7_uvect:
    case tc7_fvect:
    case tc7_dvect:
    case tc7_cvect:
      raprin1(exp, port, writing);
      break;
    case tcs_subrs:
      lputs("#<primitive-procedure ", port);
      lputs(CHARS(SNAME(exp)), port);
      lputc('>', port);
      break;
    case tc7_specfun:
#ifdef CCLO
      if (tc16_cclo==TYP16(exp)) {
	lputs("#<compiled-closure ", port);
	iprin1(CCLO_SUBR(exp), port, writing);
	lputc('>', port);
	break;
      }
#endif
      lputs("#<primitive-procedure ", port);
      lputs(CHARS(CDR(exp)), port);
      lputc('>', port);
      break;
    case tc7_contin:
      lputs("#<continuation ", port);
      intprint(LENGTH(exp), -10, port);
      lputs(" @ ", port);
      intprint((long)CHARS(exp), -16, port);
      lputc('>', port);
      break;
    case tc7_port:
      i = PTOBNUM(exp);
      if (i<numptob && ptobs[i].print && (ptobs[i].print)(exp, port, writing))
	break;
      goto punk;
    case tc7_smob:
      i = SMOBNUM(exp);
      if (i<numsmob && smobs[i].print && (smobs[i].print)(exp, port, writing))
	break;
      goto punk;
    default: punk: ipruk("type", exp, port);
    }
  }
}

#ifndef GO32
static char s_char_readyp[]="char-ready?";
#endif

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

# ifdef HAVE_SELECT
#  ifdef HAVE_SYS_TIME_H
#   include <sys/time.h>
#  endif
# endif

static int input_waiting(f)
     FILE *f;
{
# ifdef HAVE_SELECT
  fd_set ifds;
  struct timeval tv;
  int ret;

  FD_ZERO(&ifds);
  FD_SET(fileno(f), &ifds);
  tv.tv_sec = 0;
  tv.tv_usec = 0;
  SYSCALL(ret = select((fileno(f) + 1), &ifds, (fd_set *) NULL,
		 (fd_set *) NULL, &tv););
  ASSERT(ret>=0, MAKINUM(ret), "select error", s_char_readyp);
  return FD_ISSET(fileno(f), &ifds);
# else
#  ifdef FIONREAD
  long remir;
  if (feof(f)) return 1;
  ioctl(fileno(f), FIONREAD, &remir);
  return remir;
#  else
  return -1;
#  endif
# endif
}
#endif
/* perhaps should undefine MSDOS from __IBMC__ here */
#ifndef GO32
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) || !(BUF0 & CAR(port))) return BOOL_T;
  return input_waiting(STREAM(port)) ? BOOL_T : BOOL_F;
}
#endif

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

void lfflush(port)		/* internal SCM call */
     SCM port;
{
  sizet i = PTOBNUM(port);
  (ptobs[i].fflush)(STREAM(port));
}
static char	s_flush[] = "force-output";
SCM lflush(port)		/* user accessible as 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((ptobs[i].fflush)(STREAM(port)););
	  return UNSPECIFIED;
	}
}

SCM lwrite(obj, port)
     SCM obj, port;
{
	if UNBNDP(port) port = cur_outp;
	else ASSERT(NIMP(port) && OPOUTPORTP(port), port, ARG2, s_write);
	iprin1(obj, port, 1);
#ifdef HAVE_PIPE
# ifdef EPIPE
	if (EPIPE==errno) close_port(port);
# endif
#endif
	return UNSPECIFIED;
}
SCM display(obj, port)
     SCM obj, port;
{
	if UNBNDP(port) port = cur_outp;
	else ASSERT(NIMP(port) && OPOUTPORTP(port), port, ARG2, s_display);
	iprin1(obj, port, 0);
#ifdef HAVE_PIPE
# ifdef EPIPE
	if (EPIPE==errno) close_port(port);
# endif
#endif
	return UNSPECIFIED;
}
SCM newline(port)
     SCM port;
{
	if UNBNDP(port) port = cur_outp;
	else ASSERT(NIMP(port) && OPOUTPORTP(port), port, ARG1, s_newline);
	lputc('\n', port);
#ifdef HAVE_PIPE
# ifdef EPIPE
	if (EPIPE==errno) close_port(port);
	else
# endif
#endif
	  if (port==cur_outp) lfflush(port);
	return UNSPECIFIED;
}
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);
	lputc((int)ICHR(chr), port);
#ifdef HAVE_PIPE
# ifdef EPIPE
	if (EPIPE==errno) close_port(port);
# endif
#endif
	return UNSPECIFIED;
}

FILE *trans = 0;
SCM trans_on(fil)
     SCM fil;
{
  transcript = try_open_file(fil, makfromstr("w", (sizet)sizeof(char)));
  if FALSEP(transcript) trans = 0;
  else trans = STREAM(transcript);
  return UNSPECIFIED;
}
SCM trans_off()
{
  if (!FALSEP(transcript)) close_port(transcript);
  transcript = BOOL_F;
  trans = 0;
  return UNSPECIFIED;
}

void lputc(c, port)
     int c;
     SCM port;
{
  sizet i = PTOBNUM(port);
  SYSCALL((ptobs[i].fputc)(c, STREAM(port)););
  if (trans && (port==def_outp || port==cur_errp))
    SYSCALL(fputc(c, trans););
}
void lputs(s, port)
     char *s;
     SCM port;
{
  sizet i = PTOBNUM(port);
  ASSERT(s, INUM0, ARG1, "lputs");
  SYSCALL((ptobs[i].fputs)(s, STREAM(port)););
  if (trans && (port==def_outp || port==cur_errp))
    SYSCALL(fputs(s, trans););
}
int lfwrite(ptr, size, nitems, port)
     char *ptr;
     sizet size;
     sizet nitems;
     SCM port;
{
  int ret;
  sizet i = PTOBNUM(port);
  SYSCALL(ret = (ptobs[i].fwrite)
	  (ptr, size, nitems, STREAM(port)););
  if (trans && (port==def_outp || port==cur_errp))
    SYSCALL(fwrite(ptr, size, nitems, trans););
  return ret;
}

int 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 = (ptobs[i].fgetc)(f);
#else
  SYSCALL(c = (ptobs[i].fgetc)(f););
#endif
  if (trans && (f==stdin)) SYSCALL(fputc(c, trans););
  return c;
}
void lungetc(c, port)
  int c;
  SCM port;
{
/*	ASSERT(!CRDYP(port), port, ARG2, "too many lungetc");*/
	CUNGET(c, port);
}

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 = lgetc(port);
  if (EOF==c) return EOF_VAL;
  return MAKICHR(c);
}
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 = lgetc(port);
	if (EOF==c) return EOF_VAL;
	lungetc(c, port);
	return MAKICHR(c);
}

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

static int flush_ws(port)
     SCM port;
{
  register int c;
  while(1) switch (c = lgetc(port)) {
    case ';': lp: switch (c = lgetc(port)) {
      default: goto lp;
      case EOF: return c;
      case LINE_INCREMENTORS: break;
    }
    case LINE_INCREMENTORS: if (port==loadport) linum++;
    case WHITE_SPACES: break;
    case EOF:
    default:
      return c;
  }
}
SCM lread(port)
     SCM port;
{
	int c;
	SCM tok_buf;
	if UNBNDP(port) port = cur_inp;
	else ASSERT(NIMP(port) && OPINPORTP(port), port, ARG1, s_read);
	do {
	  c = flush_ws(port);
	  if (EOF==c) return EOF_VAL;
	  lungetc(c, port);
	  tok_buf = makstr(30L);
	} while (EOF_VAL==(tok_buf = lreadr(tok_buf, port)));
	return tok_buf;
}
static SCM lreadpr(tok_buf, port)
     SCM tok_buf;
     SCM port;
{
	int c;
	sizet j;
	SCM p;
tryagain:
	c = flush_ws(port);
	switch (c) {
	case EOF: return EOF_VAL;
#ifdef BRACKETS_AS_PARENS
	case '[':
#endif
	case '(': return lreadparen(tok_buf, port, s_list);
#ifdef BRACKETS_AS_PARENS
	case ']':
#endif
	case ')': return UNDEFINED; /* goto tryagain; */
	case '\'': return cons2(i_quote, lreadr(tok_buf, port), EOL);
	case '`': return cons2(i_quasiquote, lreadr(tok_buf, port), EOL);
	case ',':
		c = lgetc(port);
		if ('@'==c) p = i_uq_splicing;
		else {
			lungetc(c, port);
			p = i_unquote;
		}
		return cons2(p, lreadr(tok_buf, port), EOL);
	case '#':
		c = lgetc(port);
		switch (c) {
#ifdef BRACKETS_AS_PARENS
		case '[':
#endif
		case '(':
			p = lreadparen(tok_buf, port, s_vector);
			return NULLP(p) ? nullvect : 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':
			lungetc(c, port);
			c = '#';
			goto num;
		case '*':
			j = read_token(c, tok_buf, port);
			p = istr2bve(CHARS(tok_buf)+1, (long)(j-1));
			if (NFALSEP(p)) return p;
			else goto unkshrp;
		case '\\':
			c = lgetc(port);
			j = read_token(c, tok_buf, port);
			if (j==1) return MAKICHR(c);
			if (c >= '0' && c < '8') {
			  p = istr2int(CHARS(tok_buf), (long)j, 8);
			  if (NFALSEP(p)) return MAKICHR(INUM(p));
			}
			for (c = 0;c<sizeof charnames/sizeof(char *);c++)
			  if (charnames[c]
			      && (0==strcmp(charnames[c], CHARS(tok_buf))))
			    return MAKICHR(charnums[c]);
			wta(UNDEFINED, "unknown # object: #\\", CHARS(tok_buf));
		case '|':
			j = 1;	/* here j is the comment nesting depth */
lp:			c = lgetc(port);
lpc:			switch (c) {
			case EOF:
			  wta(UNDEFINED, s_eofin, "balanced comment");
			case LINE_INCREMENTORS:
			  if (port==loadport) linum++;
			default:
			  goto lp;
			case '|':
			  if ('#' != (c = lgetc(port))) goto lpc;
			  if (--j) goto lp;
			  break;
			case '#':
			  if ('|' != (c = lgetc(port))) goto lpc;
			  ++j; goto lp;
			}
			goto tryagain;
		default: callshrp:
			p = CDR(intern("read:sharp", (sizeof "read:sharp")-1));
			if NIMP(p) {
			  p = apply(p, cons2(MAKICHR(c), port, EOL), EOL);
		      /*  p = apply(p, MAKICHR(c), acons(port, EOL, EOL)); */
			  if (UNSPECIFIED==p) goto tryagain;
			  return p;
			}
		      unkshrp: wta((SCM)MAKICHR(c), s_unknown_sharp, "");
		}
	case '\"':
		j = 0;
		while ('\"' != (c = lgetc(port))) {
			ASSERT(EOF != c, UNDEFINED, s_eofin, s_string);
			if (j+1 >= LENGTH(tok_buf)) grow_tok_buf(tok_buf);
			if (c=='\\') switch (c = 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 makfromstr(CHARS(tok_buf), j);
	case DIGITS:
	case '.': case '-': case '+':
num:
		j = read_token(c, tok_buf, port);
		p = istring2number(CHARS(tok_buf), (long)j, 10L);
		if NFALSEP(p) return p;
	        if (c=='#') {
		  if ((j==2) && (lgetc(port)=='(')) {
		    lungetc('(', port);
		    c = CHARS(tok_buf)[1];
		    goto callshrp;
		  }
		  wta(UNDEFINED, s_unknown_sharp, CHARS(tok_buf));
		}
	        goto tok;
	default:
		j = read_token(c, tok_buf, port);
tok:
		p = intern(CHARS(tok_buf), j);
		return CAR(p);
	}
}
static SCM lreadr(tok_buf, port)
     SCM tok_buf;
     SCM port;
{
  SCM ans = lreadpr(tok_buf, port);
  switch (ans) {
  case UNDEFINED:
    warn("unexpected \")\"", "");
    return lreadpr(tok_buf, port);
  }
  return ans;
}

#ifdef _UNICOS
_Pragma("noopt");		/* # pragma _CRI noopt */
#endif
static sizet read_token(ic, tok_buf, port)
     int ic;
     SCM tok_buf;
     SCM port;
{
	register sizet j = 1;
	register int c = ic;
	register char *p = CHARS(tok_buf);
	p[0] = downcase[c];
	while(1) {
		if (j+1 >= LENGTH(tok_buf)) p = grow_tok_buf(tok_buf);
		switch (c = lgetc(port)) {
#ifdef BRACKETS_AS_PARENS
		case '[': case ']':
#endif
		case '(': case ')': case '\"': case ';':
		case ',': case '`':
		  /* case '#': */
		case WHITE_SPACES:
		case LINE_INCREMENTORS:
			lungetc(c, port);
		case EOF:
			p[j] = 0;
			return j;
		default:
			p[j++] = downcase[c];
		}
	}
}
#ifdef _UNICOS
_Pragma("opt");			/* # pragma _CRI opt */
#endif

static SCM lreadparen(tok_buf, port, name)
     SCM tok_buf;
     SCM port;
     char *name;
{
  SCM lst, fst, tmp = lreadpr(tok_buf, port);
  if (UNDEFINED==tmp) return EOL;
  if (i_dot==tmp) {
    fst = lreadr(tok_buf, port);
  closeit:
    tmp = lreadpr(tok_buf, port);
    if (UNDEFINED != tmp) wta(UNDEFINED, "missing close paren", "");
    return fst;
  }
  fst = lst = cons(tmp, EOL);
  while (UNDEFINED != (tmp = lreadpr(tok_buf, port))) {
    if (EOF_VAL==tmp) wta(lst, s_eofin, s_list);
    if (i_dot==tmp) {
      CDR(lst) = lreadr(tok_buf, port);
      goto closeit;
    }
    lst = (CDR(lst) = cons(tmp, EOL));
  }
  return fst;
}

/* These procedures implement synchronization primitives.  Processors
   with an atomic test-and-set instruction can use it here (and not
   DEFER_INTS). */
char s_tryarb[] = "try-arbiter";
char s_relarb[] = "release-arbiter";
long tc16_arbiter;
SCM tryarb(arb)
     SCM arb;
{
  ASSERT((TYP16(arb)==tc16_arbiter), arb, ARG1, s_tryarb);
  DEFER_INTS;
  if (CAR(arb) & (1L<<16))
    arb = BOOL_F;
  else {
    CAR(arb) = tc16_arbiter | (1L<<16);
    arb = BOOL_T;
  }
  ALLOW_INTS;
  return arb;
}
SCM relarb(arb)
     SCM arb;
{
  ASSERT((TYP16(arb)==tc16_arbiter), arb, ARG1, s_relarb);
  if (!(CAR(arb) & (1L<<16))) return BOOL_F;
  CAR(arb) = tc16_arbiter;
  return BOOL_T;
}
SCM makarb(name)
     SCM name;
{
  register SCM z;
  NEWCELL(z);
  CDR(z) = name;
  CAR(z) = tc16_arbiter;
  return z;
}
static int prinarb(exp, port, writing)
     SCM exp; SCM port; int writing;
{
  lputs("#<arbiter ", port);
  if (CAR(exp) & (1L<<16)) lputs("locked ", port);
  iprin1(CDR(exp), port, writing);
  lputc('>', port);
  return !0;
}

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

struct errdesc {char *msg;char *s_response;short parent_err;};
struct errdesc 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},
  {"Thrashing", "thrashing", 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},
  {"profile interrupt", "profile-interrupt", 0},
};

void (* deferred_proc) P((void)) = 0;
int errjmp_bad = 1, ints_disabled = 1;
unsigned long SIG_deferred = 0;
SCM err_exp, err_env;
char *err_pos, *err_s_subr;
cell tmp_errobj = {(SCM)UNDEFINED, (SCM)EOL};
cell tmp_loadpath = {(SCM)BOOL_F, (SCM)EOL};
SCM *loc_errobj = (SCM *)&tmp_errobj;
SCM *loc_loadpath = (SCM *)&tmp_loadpath;
SCM loadport = UNDEFINED;
long linum = 1;
int scm_verbose = 1;
long cells_allocated = 0, lcells_allocated = 0,
  mallocated = 0, lmallocated = 0,
  rt = 0, gc_rt, gc_time_taken;
long gc_cells_collected, gc_malloc_collected, gc_ports_collected;
long gc_syms_collected;
long scm_env_work = 0,  scm_gcs = 0, scm_egcs = 0,
  scm_stk_moved = 0, scm_clo_moved = 0, scm_egc_rt;
static void def_err_response P((void));

int handle_it(i)
     int i;
{
  char *name = errmsgs[i-WNA].s_response;
  SCM proc;
  if (errjmp_bad)
    wta(UNDEFINED, (char *)i, ""); /* sends it to def_err_response */
  if (name) {
    SCM n[2];
    int j;
    for (j=0; j<2; j++) {
      NEWCELL(n[j]);		/* discard 2 possibly-used cells */
    }
    CDR(n[1]) = EOL;
    proc = CDR(intern(name, (sizet)strlen(name)));
    if NIMP(proc) {	  /* Save environment stack, in case it
			     moves when applying proc.  Do an ecache gc
			     to protect contents of stack. */
      SCM estk, *estk_ptr, env, env_tmp;
      DEFER_INTS;
#ifndef NO_ENV_CACHE
      scm_egc();
#endif
      estk = scm_estk;
      estk_ptr = scm_estk_ptr;
      env = scm_env;
      env_tmp = scm_env_tmp;
      scm_estk = BOOL_F;
      scm_estk_reset();
      ALLOW_INTS;
      apply(proc, EOL, EOL);
      DEFER_INTS;
      scm_estk = estk;
      scm_estk_ptr = estk_ptr;
      scm_env = env;
      scm_env_tmp = env_tmp;
      scm_fill_freelist();
      ALLOW_INTS;
      return i;
    }
  }
  return errmsgs[i-WNA].parent_err;
}
static char s_eval_string[] = "eval-string";
static char s_load_string[] = "load-string";
SCM scm_eval_string(str)
     SCM str;
{
  str = mkstrport(INUM0, str, OPN | RDNG, s_eval_string);
  str = lread(str);
  return EVAL(str, (SCM)EOL);
}
SCM scm_load_string(str)
     SCM str;
{
  ASSERT(NIMP(str) && (STRINGP(str) || SYMBOLP(str)), str, ARG1,
	 s_load_string);
  str = mkstrport(INUM0, str, OPN | RDNG, s_load_string);
  while(1) {
    SCM form = lread(str);
    if (EOF_VAL==form) break;
    SIDEVAL(form, EOL);
  }
  return BOOL_T;
}

SCM exitval = MAKINUM(EXIT_FAILURE); /* INUM return value */
extern char s_unexec[];
SCM repl_driver(initpath)
     char *initpath;
{
#ifdef _UNICOS
  int i;
#else
  long i;
#endif
  CONT(rootcont)->stkbse = (STACKITEM *)&i;
  i = setjump(CONT(rootcont)->jmpbuf);
#ifndef SHORT_INT
  if (i) i = UNCOOK(i);
#endif
  /* printf("repl_driver got %d\n", i); */
 drloop:
  switch ((int)i) {
  default: {
    char *name = errmsgs[i-WNA].s_response;
    if (name) {
      SCM proc = CDR(intern(name, (sizet)strlen(name)));
      if NIMP(proc) apply(proc, EOL, EOL);
    }
    if ((i = errmsgs[i-WNA].parent_err)) goto drloop;
    def_err_response();
    goto reset_toplvl;
  }
  case 0:
    exitval = MAKINUM(EXIT_SUCCESS);
    errjmp_bad = 0;
    lflush(sys_errp);
    errno = 0;
    SIG_deferred = 0;
    deferred_proc = 0;
    ints_disabled = 0;
    if (dumped) {
      lcells_allocated = cells_allocated;
      lmallocated = mallocated;
      rt = INUM(my_time());
      gc_time_taken = 0;
    }
    else if (scm_ldfile(initpath)) /* load Scheme init files */
      wta(*loc_errobj, "Could not open file", s_load);
    {
      SCM boot_tail = scm_evstr("boot-tail");
      /* initialization tail-call */
      apply(boot_tail, (dumped ? BOOL_T : BOOL_F), listofnull);
    }
  case -2:			/* abrt */
  reset_toplvl:
    ints_disabled = 1;
    errjmp_bad = 0;
    lflush(sys_errp);
    SIG_deferred = 0;
    deferred_proc = 0;
    scm_estk_reset();

    /* Closing the loading file turned out to be a bad idea. */
    /* But I will leave the code here in case someone wants it. */
#ifdef CLOSE_LOADING_PORTS_ON_ABORT
    if (NIMP(loadport) && OPINPORTP(loadport)) {
      if (scm_verbose > 1) {
	lputs("; Aborting load (closing): ", cur_errp);
	display(*loc_loadpath, cur_errp);
	newline(cur_errp);
      }
      close_port(loadport);	/* close loading file. */
    }
#endif
    *loc_loadpath = BOOL_F;
    loadport = UNDEFINED;
    ints_disabled = 0;
    repl();
    err_pos = (char *)EXIT;
    i = EXIT;
    goto drloop;		/* encountered EOF on stdin */
  case -1:			/* quit */
    return exitval;
  case -3:			/* restart. */
    return 0;
#ifdef CAN_DUMP
  case -4:			/* dump */
    DEFER_INTS;
    scm_estk_reset();
    scm_egc();
    igc(s_unexec, (STACKITEM *)0);
    ALLOW_INTS;
    dumped = 1;
# ifdef linux    
				/* The last few words of the .data segment
				   were not being mapped in for dumped
				   executables. */
    sbrk(getpagesize());
# endif
    unexec(CHARS(*loc_errobj), execpath, 0, 0, 0);
    goto reset_toplvl;
#endif
  }
}

SCM line_num()
{
  return MAKINUM(linum);
}
SCM prog_args()
{
  return progargs;
}

extern char s_heap[];
extern sizet hplim_ind;
extern CELLPTR *hplims;
void growth_mon(obj, size, units, grewp)
     char *obj;
     long size;
     char *units;
     int grewp;
{
  if (verbose>2)
    {
      lputs((grewp ? "; grew " : "; shrank "), sys_errp);
      lputs(obj, sys_errp);
      lputs(" to ", sys_errp);
      intprint(size, -10, sys_errp);
      lputc(' ', sys_errp);
      lputs(units, sys_errp);
      if ((verbose>4) && (obj==s_heap)) heap_report();
      lputs("\n", sys_errp);
    }
}

void gc_start(what)
     char *what;
{
  if (verbose>3 && FPORTP(cur_errp)) {
    lputs(";GC(", sys_errp);
    lputs(what, sys_errp);
    lputs(")", sys_errp);
  }
  scm_gcs++;
  gc_rt = INUM(my_time());
  gc_cells_collected = 0;
  gc_malloc_collected = 0;
  gc_ports_collected = 0;
  gc_syms_collected = 0;
}
void gc_end()
{
  gc_rt = INUM(my_time()) - gc_rt;
  gc_time_taken = gc_time_taken + gc_rt;
  if (verbose>3) {
    if (!FPORTP(cur_errp)) lputs(";GC ", sys_errp);
    intprint(time_in_msec(gc_rt), -10, sys_errp);
    lputs(" cpu mSec, ", sys_errp);
    intprint(gc_cells_collected, -10, sys_errp);
    lputs(" cells, ", sys_errp);
    intprint(gc_malloc_collected, -10, sys_errp);
    lputs(" malloc, ", sys_errp);
    intprint(gc_syms_collected, -10, sys_errp);
    lputs(" syms, ", sys_errp);
    intprint(gc_ports_collected, -10, sys_errp);
    lputs(" ports collected\n", sys_errp);
  }
}
void scm_egc_start()
{
  scm_egc_rt = INUM(my_time());
  scm_egcs++;
}
void scm_egc_end()
{
  scm_egc_rt = INUM(my_time()) - scm_egc_rt;
  gc_time_taken = gc_time_taken + scm_egc_rt;
}
void repl_report()
{
  if (verbose>1) {
    lfflush(cur_outp);
    lputs(";Evaluation took ", cur_errp);
    intprint(time_in_msec(INUM(my_time())-rt), -10, cur_errp);
    lputs(" mSec (", cur_errp);
    intprint(time_in_msec(gc_time_taken), -10, cur_errp);
    lputs(" in gc) ", cur_errp);
    intprint(cells_allocated - lcells_allocated, -10, cur_errp);
    lputs(" cells work, ", cur_errp);
    scm_env_work += scm_ecache_len - scm_ecache_index;
    intprint(scm_env_work, -10, cur_errp);
    lputs(" env, ", cur_errp);
    intprint(mallocated - lmallocated, -10, cur_errp);
    lputs(" bytes other\n", cur_errp);
    if (verbose>2) {
      lputc(';', cur_errp);
      intprint(scm_gcs, -10, cur_errp);
      lputs( " gc, ", cur_errp);
      intprint(scm_egcs, -10, cur_errp);
      lputs( " ecache gc, ", cur_errp);
      intprint(scm_clo_moved, -10, cur_errp);
      lputs(" env migrated from closures, ", cur_errp);
      intprint(scm_stk_moved, -10, cur_errp);
      lputs(" from stack\n", cur_errp);
    }
    lfflush(cur_errp);
  }
}
#ifndef LACK_SBRK
extern long scm_init_brk, scm_dumped_brk;
void scm_brk_report()
{
  long scm_curbrk = sbrk(0),
    dif1 = ((dumped ? scm_dumped_brk : scm_curbrk) - scm_init_brk)/1024,
    dif2 = (scm_curbrk - scm_dumped_brk)/1024;
    
  lputs("initial brk = 0x", cur_errp);
  intprint(scm_init_brk, -16, cur_errp);
  if (dumped) {
    lputs(", dumped = 0x", cur_errp);
    intprint(scm_dumped_brk, -16, cur_errp);
  }
  lputs(", current = 0x", cur_errp);
  intprint(scm_curbrk, -16, cur_errp);
  lputs("; ", cur_errp);
  intprint(dif1, 10, cur_errp);
  if (dumped) {
    lputs(dif2<0 ? " - " : " + ", cur_errp);
    intprint(dif2<0 ? -dif2 : dif2, 10, cur_errp);
  }
  lputs(" kb\n", cur_errp);
}
#endif
#ifdef NUM_HP
extern long num_hp_total;
#endif
SCM lroom(opt)
     SCM opt;
{
  intprint(cells_allocated, -10, cur_errp);
  lputs(" out of ", cur_errp);
  intprint(heap_cells, -10, cur_errp);
  lputs(" cells in use, ", cur_errp);
  intprint(mallocated, -10, cur_errp);
  lputs(" bytes allocated (of ", cur_errp);
  intprint(mtrigger, 10, cur_errp);
  lputs(")\n", cur_errp);
  if (!UNBNDP(opt)) {
#ifdef NUM_HP
    intprint(num_hp_total, 10, cur_errp);
    lputs(" bytes allocated for flonums/bignums\n", cur_errp);
#endif
#ifndef LACK_SBRK
    scm_brk_report();
#endif
    scm_ecache_report();
    heap_report();
    lputc('\n', cur_errp);
    stack_report();
  }
  return UNSPECIFIED;
}
void heap_report()
{
  sizet i = 0;
  lputs(";; heap segments:", sys_errp);
  while(i < hplim_ind) {
    {
      long seg_cells = CELL_DN(hplims[i+1]) - CELL_UP(hplims[i]);
      lputs("\n; 0x", sys_errp);
      intprint((long)hplims[i++], -16, sys_errp);
      lputs(" - 0x", sys_errp);
      intprint((long)hplims[i++], -16, sys_errp);
      lputs("; ", sys_errp);
      intprint(seg_cells, 10, sys_errp);
      lputs(" cells; ", sys_errp);
      intprint(seg_cells / (1024 / sizeof(CELLPTR)), 10, sys_errp);
      lputs(" kb", sys_errp);
    }}
}
void scm_ecache_report()
{
  long n = LENGTH(scm_estk) - 1;
  while (n-- && VELTS(scm_estk)[n]==UNSPECIFIED)
    ;
  intprint(n + 1L, 10 , cur_errp);
  lputs(" out of ", cur_errp);
  intprint(LENGTH(scm_estk), 10, cur_errp);
  lputs(" env stack items touched, ", cur_errp);
  intprint(scm_ecache_len - scm_ecache_index, 10, cur_errp);
  lputs(" out of ", cur_errp);
  intprint(scm_ecache_len, 10, cur_errp);
  lputs(" env cells in use.\n", cur_errp);
}
void exit_report()
{
  if (verbose>2) {
    lputs(";Totals: ", cur_errp);
    intprint(time_in_msec(INUM(my_time())), -10, cur_errp);
    lputs(" mSec my time, ", cur_errp);
    intprint(time_in_msec(INUM(your_time())), -10, cur_errp);
    lputs(" mSec your time\n", cur_errp);
  }
}

SCM prolixity(arg)
     SCM arg;
{
  int old = verbose;
  if (!UNBNDP(arg)) {
    if FALSEP(arg) scm_verbose = 1;
    else scm_verbose = INUM(arg);
  }
  return MAKINUM(old);
}

void repl()
{
  SCM x;
  int c;
  repl_report();
  while(1) {
    if OPOUTPORTP(cur_inp) {	/* This case for curses window */
      lfflush(cur_outp);
      if (verbose) lputs(PROMPT, cur_inp);
      lfflush(cur_inp);
    }
    else {
      if (verbose) lputs(PROMPT, cur_outp);
      lfflush(cur_outp);
    }
    lcells_allocated = cells_allocated;
    scm_env_work = scm_ecache_index - scm_ecache_len;
    scm_egcs = scm_clo_moved = scm_stk_moved = 0;
    lmallocated = mallocated;
    x = lread(cur_inp);
    rt = INUM(my_time());
    scm_gcs = 0;
    gc_time_taken = 0;
    if (EOF_VAL==x) break;
    if (!CRDYP(cur_inp)) {	/* assure newline read (and transcripted) */
      if (EOF==(c = lgetc(cur_inp))) break;
      lungetc(c, cur_inp);
    }
#ifdef __HIGHC__
# define __MSDOS__
#endif
#ifdef __MSDOS__
    if ('\n' != CGETUN(cur_inp))
      if OPOUTPORTP(cur_inp)	/* This case for curses window */
	{lfflush(cur_outp); newline(cur_inp);}
      else newline(cur_outp);
#endif
    x = EVAL(x, (SCM)EOL);
    repl_report();
    iprin1(x, cur_outp, 1);
    lputc('\n', cur_outp);
  }
}
SCM quit(n)
     SCM n;
{
  if (UNBNDP(n) || BOOL_T==n) n = MAKINUM(EXIT_SUCCESS);
  if INUMP(n) exitval = n;
  else exitval = MAKINUM(EXIT_FAILURE);
  if (errjmp_bad) exit(INUM(exitval));
  dowinds(EOL, ilength(dynwinds));
  longjump(CONT(rootcont)->jmpbuf, COOKIE(-1));
}
SCM abrt()
{
  if (errjmp_bad) exit(EXIT_FAILURE);
  dowinds(EOL, ilength(dynwinds));
  longjump(CONT(rootcont)->jmpbuf, COOKIE(-2));
}
char s_restart[] = "restart";
SCM restart()
{
  /* ASSERT(!dumped, UNDEFINED, "dumped can't", s_restart); */
  dowinds(EOL, ilength(dynwinds));
  longjump(CONT(rootcont)->jmpbuf, COOKIE(-3));
}

char s_no_ep[] = "no execpath";
#define s_execpath (s_no_ep+3)
SCM scm_execpath(newpath)
     SCM newpath;
{
  SCM retval = execpath ? makfrom0str(execpath) : BOOL_F;
  if (UNBNDP(newpath))
    return retval;
  if (FALSEP(newpath) || BOOL_T==newpath) {
    if (execpath) free(execpath);
    execpath = 0;
    if (BOOL_T==newpath) {
      execpath = scm_find_executable();
      return execpath ? makfrom0str(execpath) : BOOL_F;
    }
    else return retval;
  }
  ASSERT(NIMP(newpath) && STRINGP(newpath), newpath, ARG1, s_execpath);
  if (execpath) free(execpath);
  execpath = (char *)malloc((sizet)(LENGTH(newpath) + 1));
  ASSERT(execpath, newpath, NALLOC, s_execpath);
  strncpy(execpath, CHARS(newpath), LENGTH(newpath) + 1);
  return retval;
}

#ifdef CAN_DUMP
char s_unexec[] = "unexec";
SCM scm_unexec(newpath)
     SCM newpath;
{
  ASSERT(NIMP(newpath) && STRINGP(newpath), newpath, ARG1, s_unexec);
  ASSERT(execpath, UNSPECIFIED, s_no_ep, s_unexec);
  *loc_errobj = newpath;
  longjump(CONT(rootcont)->jmpbuf, COOKIE(-4));
}
#endif

#ifdef CAREFUL_INTS
ints_infot *ints_info = 0;
static void ints_viol_iprin(num)
     long num;
{
  char num_buf[INTBUFLEN];
  sizet i = iint2str(num, 10, num_buf);
  num_buf[i] = 0;
  fputs(num_buf, stderr);
}
void ints_viol(info, sense)
     ints_infot *info;
     int sense;
{
  fputs(info->fname, stderr);
  fputc(':', stderr);
  ints_viol_iprin(info->linum);
  fputs(": ints already ", stderr);
  fputs(sense ? "dis" : "en", stderr);
  fputs("abled (", stderr);
  ints_viol_iprin((long)ints_disabled);
  fputs(")\n", stderr);
  if (ints_info) {
    fputs(ints_info->fname, stderr);
    fputc(':', stderr);
    ints_viol_iprin(ints_info->linum);
    fputs(": last change\n", stderr);
  }
  ints_info = info;
}
void ints_warn(str1, str2, fname, linum)
     char *str1, *str2, *fname;
     int linum;
{
  fputs(fname, stderr);
  fputc(':', stderr);
  ints_viol_iprin(linum);
  fputs(" :uprotected call to ", stderr);
  fputs(str1, stderr);
  if (str2) {
    fputs(" (", stderr);
    fputs(str2, stderr);
    fputc(')', stderr);
  }
  fputc('\n', stderr);
}
#endif

#ifdef TAIL_RECURSIVE_LOAD
SCM tryload(filename)
     SCM filename;
{
  ASSERT(NIMP(filename) && STRINGP(filename), filename, ARG1, s_load);
  {
    SCM oloadpath = *loc_loadpath;
    SCM oloadport = loadport;
    long olninum = linum;
    SCM port, newform = BOOL_F;
    port = open_file(filename, makfromstr("r", (sizet)sizeof(char)));
    if FALSEP(port) return port;
    *loc_loadpath = filename;
    loadport = port;
    linum = 1;
    while(1) {
      SCM form = newform;
      newform = lread(port);
      if (EOF_VAL==newform) {
	close_port(port);
	linum = olninum;
	loadport = oloadport;
	*loc_loadpath = oloadpath;
	SIDEVAL(form, EOL);
	return BOOL_T;
      }
      SIDEVAL(form, EOL);
    }
  }
}
#else
SCM tryload(filename)
     SCM filename;
{
  ASSERT(NIMP(filename) && STRINGP(filename), filename, ARG1, s_load);
  {
    SCM oloadpath = *loc_loadpath;
    SCM oloadport = loadport;
    long olninum = linum;
    SCM form, port;
    port = open_file(filename, makfromstr("r", (sizet)sizeof(char)));
    if FALSEP(port) return port;
    *loc_loadpath = filename;
    loadport = port;
    linum = 1;
    while(1) {
      form = lread(port);
      if (EOF_VAL==form) break;
      SIDEVAL(form, EOL);
    }
    close_port(port);
    linum = olninum;
    loadport = oloadport;
    *loc_loadpath = oloadpath;
  }
  return BOOL_T;
}
#endif

#ifdef CAUTIOUS
static void trace1(estk, n)
     SCM estk;
     int n;
{
  SCM ste = VELTS(estk)[SCM_ESTK_BASE + n*SCM_ESTK_FRLEN + 2];
  lputs("\n\n", cur_errp);
  intprint(n, -10, cur_errp);
  lputs(": ", cur_errp);
  iprin1(ste, cur_errp, 1);
}

SCM scm_stack_trace()
{
  long n = (scm_estk_ptr - VELTS(scm_estk));
  n = (n - SCM_ESTK_BASE)/SCM_ESTK_FRLEN;
  if (0>=n) return BOOL_F;
  lputs("\n;STACK TRACE", cur_errp);
  *scm_estk_ptr = scm_env;
  if (n > 21) {
    int i;
    for (i = 0; i < 10; i++) trace1(scm_estk, n-i);
    lputs("\n\n ...", cur_errp);
    n = 10;
  }
  do {
    trace1(scm_estk, n);
  } while (--n > 0);
  return BOOL_T;
}
#endif

static void err_head(str)
     char *str;
{
  int oerrno = errno;
  exitval = MAKINUM(EXIT_FAILURE);
  if NIMP(cur_outp) lfflush(cur_outp);
  lputc('\n', cur_errp);
  if(BOOL_F != *loc_loadpath) {
    iprin1(*loc_loadpath, cur_errp, 1);
    lputs(", line ", cur_errp);
    intprint((long)linum, 10, cur_errp);
    lputs(": ", cur_errp);
  }
  lfflush(cur_errp);
  errno = oerrno;
  if (cur_errp==def_errp) {
    if (errno>0) perror(str);
    fflush(stderr);
    return;
  }
}
void warn(str1, str2)
     char *str1, *str2;
{
  err_head("WARNING");
  lputs("WARNING: ", cur_errp);
  lputs(str1, cur_errp);
  if (str2) {
    lputs(str2, cur_errp);
    lputc('\n', cur_errp);
    lfflush(cur_errp);
  }
}

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";
SCM lperror(arg)
     SCM arg;
{
  ASSERT(NIMP(arg) && STRINGP(arg), arg, ARG1, s_perror);
  err_head(CHARS(arg));
  return UNSPECIFIED;
}
static void def_err_response()
{
  SCM obj = *loc_errobj;
  DEFER_INTS;
  err_head("ERROR");
  lputs("ERROR: ", cur_errp);
  if (err_s_subr && *err_s_subr) {
    lputs(err_s_subr, cur_errp);
    lputs(": ", cur_errp);
  }
  if (err_pos==(char *)ARG1 && UNBNDP(*loc_errobj)) err_pos = (char *)WNA;
#ifdef nosve
  if ((~0x1fL) & (short)err_pos) lputs(err_pos, cur_errp);
  else if (WNA>(short)err_pos) {
    lputs("Wrong type in arg", cur_errp);
    lputc(err_pos ? '0'+(short)err_pos : ' ', cur_errp);
  }
#else
  if ((~0x1fL) & (long)err_pos) lputs(err_pos, cur_errp);
  else if (WNA>(long)err_pos) {
    lputs("Wrong type in arg", cur_errp);
    lputc(err_pos ? '0'+(int)err_pos : ' ', cur_errp);
  }
#endif
  else {
    lputs(errmsgs[((int)err_pos)-WNA].msg, cur_errp);
    goto outobj;
  }
  if (IMP(obj) || SYMBOLP(obj) || (TYP16(obj)==tc7_port)
      || (NFALSEP(procedurep(obj))) || (NFALSEP(numberp(obj)))) {
outobj:
    if (!UNBNDP(obj)) {
      lputs(((long)err_pos==WNA)?" given ":" ", cur_errp);
      iprin1(obj, cur_errp, 1);
    }
  }
  else lputs(" (see errobj)", cur_errp);
#ifdef CAUTIOUS
  scm_stack_trace();
#endif
  if UNBNDP(err_exp) goto getout;
  if NIMP(err_exp) {
    lputs("\n; in expression: ", cur_errp);
    if NCONSP(err_exp) iprin1(err_exp, cur_errp, 1);
    else if (UNDEFINED==CDR(err_exp))
      iprin1(CAR(err_exp), cur_errp, 1);
    else iprlist("(... ", err_exp, ')', cur_errp, 1);
  }
  if NULLP(err_env) lputs("\n; in top level environment.", cur_errp);
  else {
    SCM env = err_env;
    if (NIMP(env) && tc16_env==CAR(env)) env = CDR(env);
    lputs("\n; in scope:", cur_errp);
    while NNULLP(env) {
      lputc('\n', cur_errp);
      lputs(";   ", cur_errp);
      iprin1(CAR(CAR(env)), cur_errp, 1);
      env = CDR(env);
    }
  }
 getout:
  lputc('\n', cur_errp);
  lfflush(cur_errp);
  err_exp = err_env = UNDEFINED;
  if (errjmp_bad) {
    lputs("\nerrobj: ", cur_errp);
    iprin1(obj, cur_errp, 1);
    newline(cur_errp);
    lroom(BOOL_T);
    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;
}
void everr(exp, env, arg, pos, s_subr)
     SCM exp, env, arg;
     char *pos, *s_subr;
{
  err_exp = exp;
  err_env = env;
  *loc_errobj = arg;
  err_pos = pos;
  err_s_subr = s_subr;
  if (((~0x1fL) & (long)pos) || (WNA>(long)pos) || errjmp_bad) {
    def_err_response();
    abrt();
  }
  if IMP(rootcont) exit(INUM(exitval));
  dowinds(EOL, ilength(dynwinds));
  longjump(CONT(rootcont)->jmpbuf, COOKIE((int)pos));
  /* will do error processing at stack base */
}
void wta(arg, pos, s_subr)
     SCM arg;
char *pos, *s_subr;
{
 everr(UNDEFINED, EOL, arg, pos, s_subr);
}
SCM cur_input_port()
{
  return cur_inp;
}
SCM cur_output_port()
{
  return cur_outp;
}
SCM cur_error_port()
{
  return cur_errp;
}
char s_cur_inp[] = "set-current-input-port";
char s_cur_outp[] = "set-current-output-port";
char s_cur_errp[] = "set-current-error-port";
SCM set_inp(port)
     SCM port;
{
  SCM oinp = cur_inp;
  ASSERT(NIMP(port) && OPINPORTP(port), port, ARG1, s_cur_inp);
  cur_inp = port;
  return oinp;
}
SCM set_outp(port)
     SCM port;
{
  SCM ooutp = cur_outp;
  ASSERT(NIMP(port) && OPOUTPORTP(port), port, ARG1, s_cur_outp);
  cur_outp = port;
  return ooutp;
}
SCM set_errp(port)
     SCM port;
{
  SCM oerrp = cur_errp;
  ASSERT(NIMP(port) && OPOUTPORTP(port), port, ARG1, s_cur_errp);
  cur_errp = port;
  return oerrp;
}
static char s_isatty[] = "isatty?";
SCM l_isatty(port)
     SCM port;
{
  ASSERT(NIMP(port) && OPPORTP(port), port, ARG1, s_isatty);
  if (tc16_fport != TYP16(port)) return BOOL_F;
  return isatty(fileno(STREAM(port)))?BOOL_T:BOOL_F;
}

static iproc subr0s[] = {
	{&s_cur_inp[4], cur_input_port},
	{&s_cur_outp[4], cur_output_port},
	{&s_cur_errp[4], cur_error_port},
	{"transcript-off", trans_off},
	{"program-arguments", prog_args},
	{"line-number", line_num},
	{"abort", abrt},
	{s_restart, restart},
#ifdef CAUTIOUS
	{"stack-trace", scm_stack_trace},
#endif
	{0, 0}};

static iproc subr1s[] = {
	{s_cur_inp, set_inp},
	{s_cur_outp, set_outp},
	{s_cur_errp, set_errp},
	{"transcript-on", trans_on},
	{s_tryload, tryload},
	{s_load_string, scm_load_string},
	{s_eval_string, scm_eval_string},
	{s_perror, lperror},
	{"make-arbiter", makarb},
	{s_tryarb, tryarb},
	{s_relarb, relarb},
	{s_isatty, l_isatty},
	{0, 0}};

static iproc subr1os[] = {
	{s_read, lread},
	{s_read_char, scm_read_char},
	{s_peek_char, peek_char},
	{s_newline, newline},
	{s_flush, lflush},
#ifndef GO32
	{s_char_readyp, char_readyp},
#endif
	{"quit", quit},
	{"verbose", prolixity},
	{"errno", lerrno},
	{s_execpath, scm_execpath},
	{"find-init-file", scm_find_impl},
	{"room", lroom},
	{0, 0}};

static iproc subr2os[] = {
	{s_write, lwrite},
	{s_display, display},
	{s_write_char, write_char},
#ifdef CAN_DUMP
	{s_unexec, scm_unexec},
#endif
	{0, 0}};

static smobfuns arbsmob = {markcdr, free0, prinarb};
char s_ccl[] = "char-code-limit";

void init_repl( iverbose )
     int iverbose;
{
	sysintern(s_ccl, MAKINUM(CHAR_CODE_LIMIT));
	loc_errobj = &CDR(sysintern("errobj", UNDEFINED));
	loc_loadpath = &CDR(sysintern("*load-pathname*", BOOL_F));
	transcript = BOOL_F;
	trans = 0;
	linum = 1;
	scm_verbose = iverbose;
	init_iprocs(subr0s, tc7_subr_0);
	init_iprocs(subr1os, tc7_subr_1o);
	init_iprocs(subr1s, tc7_subr_1);
	init_iprocs(subr2os, tc7_subr_2o);
#ifndef GO32
	add_feature(s_char_readyp);
#endif
#ifdef CAN_DUMP
	add_feature("dump");
	scm_ldstr("\
(define (dump file . thunk)\n\
  (cond ((null? thunk) (set! *interactive* #f) (set! *argv* #f))\n\
	((not (car thunk)) (set! *argv* #f))\n\
	((boolean? (car thunk)))\n\
	(else (set! boot-tail (lambda (t) ((car thunk))))))\n\
  (set! restart exec-self)\n\
  (require #f)\n\
  (unexec file))\n\
");
#endif
#ifdef ARM_ULIB
	set_erase();
#endif
	tc16_arbiter = newsmob(&arbsmob);
}
void final_repl()
{
  loc_errobj = (SCM *)&tmp_errobj;
  loc_loadpath = (SCM *)&tmp_loadpath;
  loadport = UNDEFINED;
  transcript = BOOL_F;
  trans = 0;
  linum = 1;
}