diff options
Diffstat (limited to 'repl.c')
| -rw-r--r-- | repl.c | 498 |
1 files changed, 336 insertions, 162 deletions
@@ -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\ |