Import Upstream version 5c3upstream/5c3

1 files changed, 336 insertions, 162 deletions

diff --git a/repl.c b/repl.c
index 1593909..a60d7e8 100644
--- a/repl.c
+++ b/repl.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1997 Free Software Foundation, Inc.
+/* 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
@@ -66,7 +66,6 @@ unsigned char upcase[CHAR_CODE_LIMIT];
 unsigned char downcase[CHAR_CODE_LIMIT];
 unsigned char lowers[] = "abcdefghijklmnopqrstuvwxyz";
 unsigned char uppers[] = "ABCDEFGHIJKLMNOPQRSTUVWXYZ";
-extern int verbose;
 void init_tables()
 {
   int i;
@@ -75,7 +74,7 @@ void init_tables()
     upcase[lowers[i]] = uppers[i];
     downcase[uppers[i]] = lowers[i];
   }
-  verbose = 1;			/* Here so that monitor info won't be */
+  scm_verbose = 1;		/* Here so that monitor info won't be */
 				/* printed while in init_storage. (BOOM) */
 }
 
@@ -120,9 +119,8 @@ char *isymnames[] = {
 				/*  NUM_ISPCSYMS ISPCSYMS here */
   "#@and", "#@begin", "#@case", "#@cond", "#@do", "#@if", "#@lambda",
   "#@let", "#@let*", "#@letrec", "#@or", "#@quote", "#@set!",
-  "#@define", "#@apply", "#@call-with-current-continuation",
-  "#@farloc-car", "#@farloc-cdr", "#@delay", "#@quasiquote",
-  "#@unquote", "#@unquote-splicing", "#@else", "#@=>",
+  "#@define", "#@apply", "#@farloc-car", "#@farloc-cdr", "#@delay",
+  "#@quasiquote", "#@unquote", "#@unquote-splicing", "#@else", "#@=>",
 				/* user visible ISYMS */
 				/* other keywords */
 				/* Flags */
@@ -158,13 +156,13 @@ void ipruk(hdr, ptr, port)
   lputs(hdr, port);
   if (scm_cell_p(ptr)) {
     lputs(" (0x", port);
-    intprint(CAR(ptr), 16, port);
+    intprint(CAR(ptr), -16, port);
     lputs(" . 0x", port);
-    intprint(CDR(ptr), 16, port);
+    intprint(CDR(ptr), -16, port);
     lputs(") @", port);
   }
   lputs(" 0x", port);
-  intprint(ptr, 16, port);
+  intprint(ptr, -16, port);
   lputc('>', port);
 }
 
@@ -177,8 +175,8 @@ void iprlist(hdr, exp, tlr, port, writing)
   lputs(hdr, port);
   /* CHECK_INTS; */
   iprin1(CAR(exp), port, writing);
-  exp = CDR(exp);
-  for(;NIMP(exp);exp = CDR(exp)) {
+  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);
@@ -214,16 +212,16 @@ taloop:
 	lputs(charnames[(sizeof charnames/sizeof(char *))-1], port);
 #endif /* ndef EBCDIC */
       else if (i > '\177')
-	intprint(i, 8, port);
+	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);
+      intprint((long)IFRAME(exp), -10, port);
       lputc(ICDRP(exp)?'-':'+', port);
-      intprint((long)IDIST(exp), 10, port);
+      intprint((long)IDIST(exp), -10, port);
     }
     else goto idef;
     break;
@@ -296,18 +294,24 @@ taloop:
       lputs(CHARS(SNAME(exp)), port);
       lputc('>', port);
       break;
+    case tc7_specfun:
 #ifdef CCLO
-    case tc7_cclo:
-      lputs("#<compiled-closure ", port);
-      iprin1(CCLO_SUBR(exp), port, writing);
+      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;
-#endif
     case tc7_contin:
       lputs("#<continuation ", port);
-      intprint(LENGTH(exp), 10, port);
+      intprint(LENGTH(exp), -10, port);
       lputs(" @ ", port);
-      intprint((long)CHARS(exp), 16, port);
+      intprint((long)CHARS(exp), -16, port);
       lputc('>', port);
       break;
     case tc7_port:
@@ -325,6 +329,10 @@ taloop:
   }
 }
 
+#ifndef GO32
+static char s_char_readyp[]="char-ready?";
+#endif
+
 #ifdef __IBMC__
 # define MSDOS
 #endif
@@ -349,7 +357,7 @@ static int input_waiting(f)
 #    ifdef MWC
 #     include <sys/io.h>
 #    else
-#     ifndef THINK_C
+#     ifndef macintosh
 #      ifndef ARM_ULIB
 #       include <sys/ioctl.h>
 #      endif
@@ -371,12 +379,15 @@ static int input_waiting(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;
-  select((fileno(f) + 1), &ifds, (fd_set *) NULL, (fd_set *) NULL, &tv);
+  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
@@ -392,7 +403,6 @@ static int input_waiting(f)
 #endif
 /* perhaps should undefine MSDOS from __IBMC__ here */
 #ifndef GO32
-static char s_char_readyp[]="char-ready?";
 SCM char_readyp(port)
      SCM port;
 {
@@ -488,7 +498,7 @@ FILE *trans = 0;
 SCM trans_on(fil)
      SCM fil;
 {
-  transcript = open_file(fil, makfromstr("w", (sizet)sizeof(char)));
+  transcript = try_open_file(fil, makfromstr("w", (sizet)sizeof(char)));
   if FALSEP(transcript) trans = 0;
   else trans = STREAM(transcript);
   return UNSPECIFIED;
@@ -515,6 +525,7 @@ void lputs(s, port)
      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););
@@ -711,13 +722,11 @@ lpc:			switch (c) {
 			  ++j; goto lp;
 			}
 			goto tryagain;
-		case '.':
-			p = lreadr(tok_buf, port);
-			return EVAL(p, (SCM)EOL);
 		default: callshrp:
 			p = CDR(intern("read:sharp", (sizeof "read:sharp")-1));
 			if NIMP(p) {
-			  p = apply(p, MAKICHR(c), acons(port, EOL, EOL));
+			  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;
 			}
@@ -897,16 +906,20 @@ struct errdesc errmsgs[] = {
   {"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}
+  {"alarm", "alarm-interrupt", 0},
+  {"profile interrupt", "profile-interrupt", 0},
 };
 
-int errjmp_bad = 1, ints_disabled = 1, sig_deferred = 0, alrm_deferred;
+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};
@@ -915,12 +928,14 @@ SCM *loc_errobj = (SCM *)&tmp_errobj;
 SCM *loc_loadpath = (SCM *)&tmp_loadpath;
 SCM loadport = UNDEFINED;
 long linum = 1;
-int verbose = 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)
@@ -928,12 +943,39 @@ int handle_it(i)
 {
   char *name = errmsgs[i-WNA].s_response;
   SCM proc;
-  if (errjmp_bad) return -1;	/* sends it to def_err_response */
+  if (errjmp_bad)
+    wta(UNDEFINED, (char *)i, ""); /* sends it to def_err_response */
   if (name) {
-    NEWCELL(proc);		/* discard possibly-used cell */
+    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) {
+    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;
     }
   }
@@ -993,9 +1035,10 @@ SCM repl_driver(initpath)
   case 0:
     exitval = MAKINUM(EXIT_SUCCESS);
     errjmp_bad = 0;
+    lflush(sys_errp);
     errno = 0;
-    alrm_deferred = 0;
-    sig_deferred = 0;
+    SIG_deferred = 0;
+    deferred_proc = 0;
     ints_disabled = 0;
     if (dumped) {
       lcells_allocated = cells_allocated;
@@ -1005,19 +1048,25 @@ SCM repl_driver(initpath)
     }
     else if (scm_ldfile(initpath)) /* load Scheme init files */
       wta(*loc_errobj, "Could not open file", s_load);
-    scm_evstr("(boot-tail)");	/* initialization tail-call */
+    {
+      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;
-    alrm_deferred = 0;
-    sig_deferred = 0;
-    ints_disabled = 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 (verbose > 1) {
+      if (scm_verbose > 1) {
 	lputs("; Aborting load (closing): ", cur_errp);
 	display(*loc_loadpath, cur_errp);
 	newline(cur_errp);
@@ -1027,6 +1076,7 @@ SCM repl_driver(initpath)
 #endif
     *loc_loadpath = BOOL_F;
     loadport = UNDEFINED;
+    ints_disabled = 0;
     repl();
     err_pos = (char *)EXIT;
     i = EXIT;
@@ -1037,8 +1087,18 @@ SCM repl_driver(initpath)
     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
@@ -1057,21 +1117,22 @@ SCM prog_args()
 extern char s_heap[];
 extern sizet hplim_ind;
 extern CELLPTR *hplims;
-void growth_mon(obj, size, units)
+void growth_mon(obj, size, units, grewp)
      char *obj;
      long size;
      char *units;
+     int grewp;
 {
   if (verbose>2)
     {
-      lputs("; grew ", cur_errp);
-      lputs(obj, cur_errp);
-      lputs(" to ", cur_errp);
-      intprint(size, 10, cur_errp);
-      lputc(' ', cur_errp);
-      lputs(units, cur_errp);
+      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", cur_errp);
+      lputs("\n", sys_errp);
     }
 }
 
@@ -1079,13 +1140,11 @@ void gc_start(what)
      char *what;
 {
   if (verbose>3 && FPORTP(cur_errp)) {
-    ALLOW_INTS;
-    lputs(";GC(", cur_errp);
-    lputs(what, cur_errp);
-    lputs(")", cur_errp);
-    lfflush(cur_errp);
-    DEFER_INTS;
+    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;
@@ -1097,52 +1156,109 @@ void gc_end()
   gc_rt = INUM(my_time()) - gc_rt;
   gc_time_taken = gc_time_taken + gc_rt;
   if (verbose>3) {
-    ALLOW_INTS;
-    if (!FPORTP(cur_errp)) lputs(";GC ", cur_errp);
-    intprint(time_in_msec(gc_rt), 10, cur_errp);
-    lputs(" cpu mSec, ", cur_errp);
-    intprint(gc_cells_collected, 10, cur_errp);
-    lputs(" cells, ", cur_errp);
-    intprint(gc_malloc_collected, 10, cur_errp);
-    lputs(" malloc, ", cur_errp);
-    intprint(gc_syms_collected, 10, cur_errp);
-    lputs(" syms, ", cur_errp);
-    intprint(gc_ports_collected, 10, cur_errp);
-    lputs(" ports collected\n", cur_errp);
-    lfflush(cur_errp);
-    DEFER_INTS;
+    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);
+    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);
+    intprint(time_in_msec(gc_time_taken), -10, cur_errp);
     lputs(" in gc) ", cur_errp);
-    intprint(cells_allocated - lcells_allocated, 10, cur_errp);
+    intprint(cells_allocated - lcells_allocated, -10, cur_errp);
     lputs(" cells work, ", cur_errp);
-    intprint(mallocated - lmallocated, 10, 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);
   }
 }
-SCM lroom(args)
-     SCM args;
+#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);
+  intprint(cells_allocated, -10, cur_errp);
   lputs(" out of ", cur_errp);
-  intprint(heap_size, 10, cur_errp);
+  intprint(heap_cells, -10, cur_errp);
   lputs(" cells in use, ", cur_errp);
-  intprint(mallocated, 10, cur_errp);
+  intprint(mallocated, -10, cur_errp);
   lputs(" bytes allocated (of ", cur_errp);
   intprint(mtrigger, 10, cur_errp);
   lputs(")\n", cur_errp);
-  if NIMP(args) {
+  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();
-    lputs("\n", cur_errp);
+    lputc('\n', cur_errp);
     stack_report();
   }
   return UNSPECIFIED;
@@ -1150,21 +1266,42 @@ SCM lroom(args)
 void heap_report()
 {
   sizet i = 0;
-  lputs("; heap segments:", cur_errp);
-  while(i<hplim_ind) {
-    lputs("\n; 0x", cur_errp);
-    intprint((long)hplims[i++], 16, cur_errp);
-    lputs(" - 0x", cur_errp);
-    intprint((long)hplims[i++], 16, cur_errp);
-  }
+  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);
+    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);
+    intprint(time_in_msec(INUM(your_time())), -10, cur_errp);
     lputs(" mSec your time\n", cur_errp);
   }
 }
@@ -1174,8 +1311,8 @@ SCM prolixity(arg)
 {
   int old = verbose;
   if (!UNBNDP(arg)) {
-    if FALSEP(arg) verbose = 1;
-    else verbose = INUM(arg);
+    if FALSEP(arg) scm_verbose = 1;
+    else scm_verbose = INUM(arg);
   }
   return MAKINUM(old);
 }
@@ -1183,6 +1320,7 @@ SCM prolixity(arg)
 void repl()
 {
   SCM x;
+  int c;
   repl_report();
   while(1) {
     if OPOUTPORTP(cur_inp) {	/* This case for curses window */
@@ -1195,14 +1333,22 @@ void repl()
       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) */
-      lungetc(lgetc(cur_inp), cur_inp);
-#ifdef __TURBOC__
+    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);}
@@ -1228,9 +1374,6 @@ SCM abrt()
 {
   if (errjmp_bad) exit(EXIT_FAILURE);
   dowinds(EOL, ilength(dynwinds));
-#ifdef CAUTIOUS
-  stacktrace = EOL;
-#endif
   longjump(CONT(rootcont)->jmpbuf, COOKIE(-2));
 }
 char s_restart[] = "restart";
@@ -1238,9 +1381,6 @@ SCM restart()
 {
   /* ASSERT(!dumped, UNDEFINED, "dumped can't", s_restart); */
   dowinds(EOL, ilength(dynwinds));
-#ifdef CAUTIOUS
-  stacktrace = EOL;
-#endif
   longjump(CONT(rootcont)->jmpbuf, COOKIE(-3));
 }
 
@@ -1252,15 +1392,20 @@ SCM scm_execpath(newpath)
   SCM retval = execpath ? makfrom0str(execpath) : BOOL_F;
   if (UNBNDP(newpath))
     return retval;
-  if (FALSEP(newpath)) {
+  if (FALSEP(newpath) || BOOL_T==newpath) {
     if (execpath) free(execpath);
     execpath = 0;
-    return retval;
+    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);
-  if ((execpath = (char *)malloc((sizet)(LENGTH(newpath) + 1))))
-    strncpy(execpath, CHARS(newpath), LENGTH(newpath) + 1);
+  execpath = (char *)malloc((sizet)(LENGTH(newpath) + 1));
+  ASSERT(execpath, newpath, NALLOC, s_execpath);
+  strncpy(execpath, CHARS(newpath), LENGTH(newpath) + 1);
   return retval;
 }
 
@@ -1272,35 +1417,57 @@ SCM scm_unexec(newpath)
   ASSERT(NIMP(newpath) && STRINGP(newpath), newpath, ARG1, s_unexec);
   ASSERT(execpath, UNSPECIFIED, s_no_ep, s_unexec);
   *loc_errobj = newpath;
-# ifdef CAUTIOUS
-  stacktrace = EOL;
-# endif
   longjump(CONT(rootcont)->jmpbuf, COOKIE(-4));
 }
 #endif
 
 #ifdef CAREFUL_INTS
-void ints_viol(sense)
-     int sense;
+ints_infot *ints_info = 0;
+static void ints_viol_iprin(num)
+     long num;
 {
-  fputs(";ints already ", stderr);
-  fputs(sense ? "en" : "dis", stderr);
-  fputs("abled\n", stderr);
+  char num_buf[INTBUFLEN];
+  sizet i = iint2str(num, 10, num_buf);
+  num_buf[i] = 0;
+  fputs(num_buf, stderr);
 }
-#endif
-
-void han_sig()
+void ints_viol(info, sense)
+     ints_infot *info;
+     int sense;
 {
-  sig_deferred = 0;
-  if (INT_SIGNAL != handle_it(INT_SIGNAL))
-    wta(UNDEFINED, (char *)INT_SIGNAL, "");
+  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 han_alrm()
+void ints_warn(str1, str2, fname, linum)
+     char *str1, *str2, *fname;
+     int linum;
 {
-  alrm_deferred = 0;
-  if (ALRM_SIGNAL != handle_it(ALRM_SIGNAL))
-    wta(UNDEFINED, (char *)ALRM_SIGNAL, "");
+  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)
@@ -1362,30 +1529,33 @@ SCM tryload(filename)
 #endif
 
 #ifdef CAUTIOUS
-void scm_print_stack(stk)
-     SCM stk;
+static void trace1(estk, n)
+     SCM estk;
+     int n;
 {
-  switch (ilength(stk)) {
-  case -1:
-    lputs("\n; circular stacktrace!", cur_errp);
-    return;
-  case -2:
-    lputs("\n; stacktrace not a list?", cur_errp);
-    iprin1(stk, cur_errp, 1);
-    return;
-  default:
-    while NNULLP(stk) {
-      SCM ste = CAR(stk);
-      lputc('\n', cur_errp);
-      iprin1(ste, cur_errp, 1);
-      stk = CDR(stk);
-    }
-  }
+  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()
 {
-  if (0==ilength(stacktrace)) return BOOL_F;
-  scm_print_stack(stacktrace);
+  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
@@ -1445,9 +1615,6 @@ SCM lperror(arg)
 static void def_err_response()
 {
   SCM obj = *loc_errobj;
-#ifdef CAUTIOUS
-  SCM stk = stacktrace;
-#endif
   DEFER_INTS;
   err_head("ERROR");
   lputs("ERROR: ", cur_errp);
@@ -1483,7 +1650,7 @@ outobj:
   }
   else lputs(" (see errobj)", cur_errp);
 #ifdef CAUTIOUS
-  if NNULLP(stk) scm_print_stack(stk);
+  scm_stack_trace();
 #endif
   if UNBNDP(err_exp) goto getout;
   if NIMP(err_exp) {
@@ -1496,6 +1663,7 @@ outobj:
   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);
@@ -1509,7 +1677,10 @@ outobj:
   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);
@@ -1529,21 +1700,14 @@ void everr(exp, env, arg, pos, s_subr)
   *loc_errobj = arg;
   err_pos = pos;
   err_s_subr = s_subr;
-#ifndef CAUTIOUS
-  if (((~0x1fL) & (long)pos) || (WNA>(long)pos)
-      || NIMP(dynwinds) || errjmp_bad)
-#endif
-    {
-      def_err_response();
-      dowinds(EOL, ilength(dynwinds));
-      abrt();
-    }
-#ifndef CAUTIOUS
-  /* We don't have to clear stacktrace because CAUTIOUS never gets here */
-  /* We don't have to dowinds() because dynwinds is EOL */
+  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 */
-#endif
 }
 void wta(arg, pos, s_subr)
      SCM arg;
@@ -1590,6 +1754,14 @@ SCM set_errp(port)
   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},
@@ -1617,6 +1789,7 @@ static iproc subr1s[] = {
 	{"make-arbiter", makarb},
 	{s_tryarb, tryarb},
 	{s_relarb, relarb},
+	{s_isatty, l_isatty},
 	{0, 0}};
 
 static iproc subr1os[] = {
@@ -1632,6 +1805,8 @@ static iproc subr1os[] = {
 	{"verbose", prolixity},
 	{"errno", lerrno},
 	{s_execpath, scm_execpath},
+	{"find-init-file", scm_find_impl},
+	{"room", lroom},
 	{0, 0}};
 
 static iproc subr2os[] = {
@@ -1655,12 +1830,11 @@ void init_repl( iverbose )
 	transcript = BOOL_F;
 	trans = 0;
 	linum = 1;
-	verbose = iverbose;
+	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);
-	make_subr("room", tc7_lsubr, lroom);
 #ifndef GO32
 	add_feature(s_char_readyp);
 #endif
@@ -1671,7 +1845,7 @@ void init_repl( iverbose )
   (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 (car thunk))))\n\
+	(else (set! boot-tail (lambda (t) ((car thunk))))))\n\
   (set! restart exec-self)\n\
   (require #f)\n\
   (unexec file))\n\