aboutsummaryrefslogtreecommitdiffstats
path: root/repl.c
diff options
context:
space:
mode:
Diffstat (limited to 'repl.c')
-rw-r--r--repl.c498
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\