diff options
Diffstat (limited to 'repl.c')
| -rw-r--r-- | repl.c | 856 |
1 files changed, 533 insertions, 323 deletions
@@ -1,18 +1,18 @@ -/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1997, 1998 Free Software Foundation, Inc. - * +/* Copyright (C) 1990-1999 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. + * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. * * As a special exception, the Free Software Foundation gives permission * for additional uses of the text contained in its release of GUILE. @@ -36,7 +36,7 @@ * * 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. + * If you do not wish that, delete this exception notice. */ /* "repl.c" error, read-eval-print loop, read, write and load code. @@ -47,6 +47,11 @@ 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)); +void scm_fill_freelist P((void)); + +#ifdef __CYGWIN32__ +# include <sys/types.h> +#endif #ifdef ARM_ULIB # include <termio.h> @@ -74,8 +79,6 @@ void init_tables() 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 @@ -130,6 +133,7 @@ char *isymnames[] = { 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_freshline[] = "freshline"; static char s_eofin[] = "end of file in "; static char s_unknown_sharp[] = "unknown # object"; @@ -282,16 +286,13 @@ taloop: lputc(')', port); break; case tc7_bvect: - case tc7_ivect: - case tc7_uvect: - case tc7_fvect: - case tc7_dvect: - case tc7_cvect: + case tc7_ivect: case tc7_uvect: case tc7_svect: + 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); + lputs(SNAME(exp), port); lputc('>', port); break; case tc7_specfun: @@ -299,6 +300,8 @@ taloop: if (tc16_cclo==TYP16(exp)) { lputs("#<compiled-closure ", port); iprin1(CCLO_SUBR(exp), port, writing); + lputc(' ', port); + iprin1(VELTS(exp)[1], port, writing); lputc('>', port); break; } @@ -316,8 +319,13 @@ taloop: break; case tc7_port: i = PTOBNUM(exp); - if (i<numptob && ptobs[i].print && (ptobs[i].print)(exp, port, writing)) + if (i<numptob) { + if (ptobs[i].print && (ptobs[i].print)(exp, port, writing)) + ; + else + prinport(exp, port, ptobs[i].name ? ptobs[i].name : "unknown"); break; + } goto punk; case tc7_smob: i = SMOBNUM(exp); @@ -329,17 +337,14 @@ taloop: } } -#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> +# include <io.h> +# include <conio.h> static int input_waiting(f) FILE *f; { @@ -347,7 +352,6 @@ static int input_waiting(f) if (fileno(f)==fileno(stdin) && (isatty(fileno(stdin)))) return kbhit(); return -1; } -# endif #else # ifdef _DCC # include <ioctl.h> @@ -367,10 +371,8 @@ static int input_waiting(f) # endif # endif -# ifdef HAVE_SELECT -# ifdef HAVE_SYS_TIME_H -# include <sys/time.h> -# endif +# ifdef HAVE_SYS_TIME_H +# include <sys/time.h> # endif static int input_waiting(f) @@ -402,16 +404,115 @@ static int input_waiting(f) } #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; + if (CRDYP(port) || !(BUF0 & SCM_PORTFLAGS(port))) return BOOL_T; return input_waiting(STREAM(port)) ? BOOL_T : BOOL_F; } + +#ifdef GO32 +# include <pc.h> +#endif +#ifndef HAVE_SELECT +# include <time.h> +#endif +#ifdef __STDC__ +# define timet time_t +#else +# define timet long +#endif +static char s_wfi[] = "wait-for-input"; +SCM wait_for_input(args) + SCM args; +{ + SCM how_long, port1, port, ports, ans = EOL; + int timeout, pos = ARG2; + ASSERT(!NULLP(args), INUM0, WNA, s_wfi); + how_long = CAR(args); + args = CDR(args); + if NULLP(args) port1 = cur_inp; + else { + port1 = CAR(args); + args = CDR(args); + } + timeout = num2long(how_long, (char *)ARG1, s_wfi); + ASSERT(timeout >= 0, how_long, ARG1, s_wfi); + port = port1; + ports = args; + while (1) { + ASSERT(NIMP(port) && OPINPORTP(port) && (BUF0 & SCM_PORTFLAGS(port)), + port, pos, s_wfi); + if (CRDYP(port) || feof(STREAM(port))) timeout = 0; + if (NULLP(ports)) break; + if (ARG5 <= pos) pos = ARGn; + else if (ARG1 < pos) pos = 1 + pos; + port = CAR(ports); + ports = CDR(ports); + } + { +#ifdef HAVE_SELECT + fd_set ifds; + struct timeval tv; + int ret, fd_max = 0; + + tv.tv_sec = timeout; + tv.tv_usec = 0; + + FD_ZERO(&ifds); + port = port1; + ports = args; + while (1) { + int fd = fileno(STREAM(port)); + FD_SET(fd, &ifds); + if (fd_max < fd) fd_max = fd; + + if (NULLP(ports)) break; + port = CAR(ports); + ports = CDR(ports); + } + SYSCALL(ret = select(fd_max + 1, &ifds, (fd_set *)0L, (fd_set *)0L, &tv);); + ASSERT(ret>=0, MAKINUM(ret), "select error", s_wfi); + + port = port1; + ports = args; + while (1) { + if (FD_ISSET(fileno(STREAM(port)), &ifds) + || CRDYP(port) || feof(STREAM(port))) + ans = cons(port, ans); + if (NULLP(ports)) break; + port = CAR(ports); + ports = CDR(ports); + } +#else + timet start = 0; + time(&start); + start = start + timeout; + port = port1; + ports = args; + do { + FILE *f = STREAM(port); + if (feof(f)) ans = cons(port, ans); + else { +# ifdef FIONREAD + long remir; + ioctl(fileno(f), FIONREAD, &remir); + if (remir) ans = cons(port, ans); +# else + if (fileno(f)==fileno(stdin) && (isatty(fileno(stdin))) && kbhit()) + ans = cons(port, ans); +# endif + if (NULLP(ports)) break; + port = CAR(ports); + ports = CDR(ports); + } + } while (time((timet*)0L) < start); #endif + return NULLP(ans) ? BOOL_F : ans; + } +} SCM eof_objectp(x) SCM x; @@ -493,22 +594,21 @@ SCM write_char(chr, port) #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() +SCM scm_freshline(port) + SCM port; { - if (!FALSEP(transcript)) close_port(transcript); - transcript = BOOL_F; - trans = 0; - return UNSPECIFIED; + if UNBNDP(port) port = cur_outp; + else ASSERT(NIMP(port) && OPOUTPORTP(port), port, ARG1, s_freshline); + if (INUM0==scm_port_col(port)) return UNSPECIFIED; + 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; } void lputc(c, port) @@ -517,8 +617,17 @@ void lputc(c, port) { sizet i = PTOBNUM(port); SYSCALL((ptobs[i].fputc)(c, STREAM(port));); - if (trans && (port==def_outp || port==cur_errp)) - SYSCALL(fputc(c, trans);); + if (CRDY & CAR(port)) { + i = SCM_PORTNUM(port); + switch (c) { + case LINE_INCREMENTORS: + scm_port_table[i].line++; + scm_port_table[i].col = 0; + break; + default: + scm_port_table[i].col++; + } + } } void lputs(s, port) char *s; @@ -527,21 +636,44 @@ void lputs(s, 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);); + if (CRDY & CAR(port)) { + sizet j; + i = SCM_PORTNUM(port); + for (j = 0; s[j]; j++) { + switch (s[j]) { + case LINE_INCREMENTORS: + scm_port_table[i].line++; + scm_port_table[i].col = 0; + break; + default: + scm_port_table[i].col++; + } + } + } } -int lfwrite(ptr, size, nitems, port) +sizet lfwrite(ptr, size, nitems, port) char *ptr; sizet size; sizet nitems; SCM port; { - int ret; - sizet i = PTOBNUM(port); + sizet ret, 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);); + if (CRDY & CAR(port)) { + sizet j; + i = SCM_PORTNUM(port); + for (j = 0; j < ret*size; j++) { + switch (ptr[j]) { + case LINE_INCREMENTORS: + scm_port_table[i].line++; + scm_port_table[i].col = 0; + break; + default: + scm_port_table[i].col++; + } + } + } return ret; } @@ -550,22 +682,34 @@ int lgetc(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 */ + sizet i, j; + if (CRDY & CAR(port)) { + j = SCM_PORTNUM(port); + c = scm_port_table[j].unread; + if (c != EOF) { + scm_port_table[j].unread = EOF; + CAR(port) &= (scm_port_table[j].flags | (~0xf0000)); /* CLRDY(port) */ return c; } - f=STREAM(port); + } + 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);); + if (CRDY & CAR(port)) { /* CRDY overloaded !!*/ + switch (c) { + case LINE_INCREMENTORS: + scm_port_table[j].line++; + scm_port_table[j].colprev = scm_port_table[j].col; + scm_port_table[j].col = 0; + break; + default: + scm_port_table[j].col++; + } + } return c; } void lungetc(c, port) @@ -573,7 +717,8 @@ void lungetc(c, port) SCM port; { /* ASSERT(!CRDYP(port), port, ARG2, "too many lungetc");*/ - CUNGET(c, port); + scm_port_table[SCM_PORTNUM(port)].unread = c; + CAR(port) |= CRDY; } SCM scm_read_char(port) @@ -617,7 +762,7 @@ static int flush_ws(port) case EOF: return c; case LINE_INCREMENTORS: break; } - case LINE_INCREMENTORS: if (port==loadport) linum++; + case LINE_INCREMENTORS: case WHITE_SPACES: break; case EOF: default: @@ -639,6 +784,7 @@ SCM lread(port) } while (EOF_VAL==(tok_buf = lreadr(tok_buf, port))); return tok_buf; } +static SCM *loc_readsharp = 0, *loc_readsharpc = 0; static SCM lreadpr(tok_buf, port) SCM tok_buf; SCM port; @@ -653,7 +799,8 @@ tryagain: #ifdef BRACKETS_AS_PARENS case '[': #endif - case '(': return lreadparen(tok_buf, port, s_list); + case '(': + return lreadparen(tok_buf, port, s_list); #ifdef BRACKETS_AS_PARENS case ']': #endif @@ -702,6 +849,11 @@ tryagain: if (charnames[c] && (0==strcmp(charnames[c], CHARS(tok_buf)))) return MAKICHR(charnums[c]); + if (loc_readsharpc && NIMP(*loc_readsharpc)) { + resizuve(tok_buf, MAKINUM(j)); + p = apply(*loc_readsharpc, tok_buf, listofnull); + if ICHRP(p) return p; + } wta(UNDEFINED, "unknown # object: #\\", CHARS(tok_buf)); case '|': j = 1; /* here j is the comment nesting depth */ @@ -710,7 +862,6 @@ lpc: switch (c) { case EOF: wta(UNDEFINED, s_eofin, "balanced comment"); case LINE_INCREMENTORS: - if (port==loadport) linum++; default: goto lp; case '|': @@ -723,10 +874,8 @@ lpc: switch (c) { } 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 (loc_readsharp && NIMP(*loc_readsharp)) { + p = apply(*loc_readsharp, cons2(MAKICHR(c), port, EOL), EOL); if (UNSPECIFIED==p) goto tryagain; return p; } @@ -735,20 +884,24 @@ lpc: switch (c) { 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; + ASSERT(EOF != c, UNDEFINED, s_eofin, s_string); + if (j+1 >= LENGTH(tok_buf)) grow_tok_buf(tok_buf); + switch (c) { + case LINE_INCREMENTORS: break; + case '\\': + switch (c = lgetc(port)) { + case LINE_INCREMENTORS: 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; @@ -782,7 +935,7 @@ static SCM lreadr(tok_buf, port) SCM ans = lreadpr(tok_buf, port); switch (ans) { case UNDEFINED: - warn("unexpected \")\"", ""); + scm_warn("unexpected \")\"", ""); return lreadpr(tok_buf, port); } return ans; @@ -835,7 +988,7 @@ static SCM lreadparen(tok_buf, port, name) fst = lreadr(tok_buf, port); closeit: tmp = lreadpr(tok_buf, port); - if (UNDEFINED != tmp) wta(UNDEFINED, "missing close paren", ""); + if (UNDEFINED != tmp) wta(UNDEFINED, "missing close paren", name); return fst; } fst = lst = cons(tmp, EOL); @@ -914,11 +1067,14 @@ struct errdesc errmsgs[] = { {"bus error", 0, 0}, {"segment violation", 0, 0}, {"alarm", "alarm-interrupt", 0}, - {"profile interrupt", "profile-interrupt", 0}, + {"virtual alarm", "virtual-alarm-interrupt", 0}, + {"profile interrupt", "profile-alarm-interrupt", 0}, }; void (* deferred_proc) P((void)) = 0; -int errjmp_bad = 1, ints_disabled = 1; +char *errjmp_bad = "init"; +int ints_disabled = 1; +static int errjmp_recursive = 0; unsigned long SIG_deferred = 0; SCM err_exp, err_env; char *err_pos, *err_s_subr; @@ -926,9 +1082,8 @@ 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; +int scm_verbose = 1; /* Low so that monitor info won't be */ + /* printed while in init_storage. (BOOM) */ long cells_allocated = 0, lcells_allocated = 0, mallocated = 0, lmallocated = 0, rt = 0, gc_rt, gc_time_taken; @@ -941,17 +1096,19 @@ 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) + char *name = errmsgs[i-WNA].s_response; + if (errjmp_bad || errjmp_recursive) wta(UNDEFINED, (char *)i, ""); /* sends it to def_err_response */ if (name) { SCM n[2]; int j; + DEFER_INTS; for (j=0; j<2; j++) { NEWCELL(n[j]); /* discard 2 possibly-used cells */ } CDR(n[1]) = EOL; + ALLOW_INTS; proc = CDR(intern(name, (sizet)strlen(name))); if NIMP(proc) { /* Save environment stack, in case it moves when applying proc. Do an ecache gc @@ -966,7 +1123,9 @@ int handle_it(i) env = scm_env; env_tmp = scm_env_tmp; scm_estk = BOOL_F; - scm_estk_reset(); + scm_estk_reset(0); + SCM_ESTK_PARENT(scm_estk) = estk; + SCM_ESTK_PARENT_INDEX(scm_estk) = MAKINUM(estk_ptr - VELTS(estk)); ALLOW_INTS; apply(proc, EOL, EOL); DEFER_INTS; @@ -1006,9 +1165,11 @@ SCM scm_load_string(str) SCM exitval = MAKINUM(EXIT_FAILURE); /* INUM return value */ extern char s_unexec[]; -SCM repl_driver(initpath) +SCM scm_top_level(initpath, toplvl_fun) char *initpath; + SCM (*toplvl_fun)(); { + SCM ret; #ifdef _UNICOS int i; #else @@ -1019,22 +1180,26 @@ SCM repl_driver(initpath) #ifndef SHORT_INT if (i) i = UNCOOK(i); #endif - /* printf("repl_driver got %d\n", i); */ + if (!toplvl_fun) toplvl_fun = repl; + /* printf("scm_top_level 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); - } + 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; + case 1: /* from everr() */ def_err_response(); + dowinds(EOL); goto reset_toplvl; - } case 0: exitval = MAKINUM(EXIT_SUCCESS); - errjmp_bad = 0; + errjmp_bad = (char *)0; + errjmp_recursive = 0; lflush(sys_errp); errno = 0; SIG_deferred = 0; @@ -1046,58 +1211,73 @@ SCM repl_driver(initpath) rt = INUM(my_time()); gc_time_taken = 0; } - else if (scm_ldfile(initpath)) /* load Scheme init files */ + else if (initpath && + (isspace(initpath[0]) || ';'==initpath[0] || '('==initpath[0])) + scm_ldstr(initpath); + else if (scm_ldfile(initpath ? 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); + if NIMP(boot_tail) + apply(boot_tail, (dumped ? makfrom0str(initpath) : BOOL_F), listofnull); } case -2: /* abrt */ reset_toplvl: + dowinds(EOL); ints_disabled = 1; - errjmp_bad = 0; + errjmp_bad = (char *)0; + errjmp_recursive = 0; lflush(sys_errp); SIG_deferred = 0; deferred_proc = 0; - scm_estk_reset(); + scm_estk_reset(0); /* 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 (NIMP(loadports) && OPINPORTP(CAR(loadports))) { if (scm_verbose > 1) { lputs("; Aborting load (closing): ", cur_errp); display(*loc_loadpath, cur_errp); newline(cur_errp); } - close_port(loadport); /* close loading file. */ + close_port(CAR(loadports)); /* close loading file. */ } #endif + *loc_loadpath = BOOL_F; - loadport = UNDEFINED; + loadports = EOL; ints_disabled = 0; - repl(); + ret = toplvl_fun(); /* typically repl() */ + if INUMP(ret) exitval = ret; err_pos = (char *)EXIT; i = EXIT; goto drloop; /* encountered EOF on stdin */ + def_err_response(); case -1: /* quit */ + dowinds(EOL); + if (MAKINUM(EXIT_SUCCESS) != exitval) { + lputs("; program args: ", cur_errp); + lwrite(progargs, cur_errp); + newline(cur_errp); + } return exitval; case -3: /* restart. */ + dowinds(EOL); return 0; #ifdef CAN_DUMP case -4: /* dump */ DEFER_INTS; - scm_estk_reset(); + scm_estk_reset(0); scm_egc(); igc(s_unexec, (STACKITEM *)0); ALLOW_INTS; dumped = 1; -# ifdef linux - /* The last few words of the .data segment +# ifdef linux + sbrk(getpagesize()); /* 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; @@ -1107,8 +1287,57 @@ SCM repl_driver(initpath) SCM line_num() { - return MAKINUM(linum); + if (IMP(loadports)) + return INUM0; + return scm_port_line(CAR(loadports)); +} +static char s_port_line[] = "port-line"; +SCM scm_port_line(port) + SCM port; +{ + sizet lnum; + ASSERT(NIMP(port) && PORTP(port), port, ARG1, s_port_line); + if (! (TRACKED & SCM_PORTFLAGS(port))) return BOOL_F; + lnum = scm_port_table[SCM_PORTNUM(port)].line; + switch (CGETUN(port)) { + default: + break; + case LINE_INCREMENTORS: + lnum--; + break; + } + return MAKINUM(lnum); } +static char s_port_col[] = "port-column"; +SCM scm_port_col(port) + SCM port; +{ + short col; + ASSERT(NIMP(port) && PORTP(port), port, ARG1, s_port_col); + if (! (TRACKED & SCM_PORTFLAGS(port))) return BOOL_F; + col = scm_port_table[SCM_PORTNUM(port)].col; + switch (CGETUN(port)) { + default: + col--; + break; + case LINE_INCREMENTORS: + col = scm_port_table[SCM_PORTNUM(port)].colprev; + break; + } + return MAKINUM(col); +} +static char s_port_filename[] = "port-filename"; +SCM scm_port_filename(port) + SCM port; +{ + SCM x; + ASSERT(NIMP(port) && PORTP(port), port, ARG1, s_port_filename); + x = SCM_PORTDATA(port); + if (NIMP(x) && STRINGP(x)) + return SCM_PORTDATA(port); + return BOOL_F; +} + SCM prog_args() { return progargs; @@ -1210,13 +1439,20 @@ void repl_report() } } #ifndef LACK_SBRK -extern long scm_init_brk, scm_dumped_brk; +unsigned long scm_init_brk = 0, scm_dumped_brk = 0; +void init_sbrk() +{ + if (dumped) + scm_dumped_brk = (unsigned long)sbrk(0); + else + scm_init_brk = (unsigned long)sbrk(0); +} void scm_brk_report() { - long scm_curbrk = sbrk(0), + unsigned 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) { @@ -1234,9 +1470,6 @@ void scm_brk_report() lputs(" kb\n", cur_errp); } #endif -#ifdef NUM_HP -extern long num_hp_total; -#endif SCM lroom(opt) SCM opt; { @@ -1249,12 +1482,8 @@ SCM lroom(opt) 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(); + if (scm_init_brk) scm_brk_report(); #endif scm_ecache_report(); heap_report(); @@ -1283,13 +1512,8 @@ void heap_report() } 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_estk_size, 10 , cur_errp); + lputs(" env stack items, ", cur_errp); intprint(scm_ecache_len - scm_ecache_index, 10, cur_errp); lputs(" out of ", cur_errp); intprint(scm_ecache_len, 10, cur_errp); @@ -1317,48 +1541,51 @@ SCM prolixity(arg) return MAKINUM(old); } -void repl() +SCM 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); - } + if OPINPORTP(cur_inp) { + 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) return MAKINUM(EXIT_SUCCESS); + 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); + 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); + x = EVAL(x, (SCM)EOL); + repl_report(); + iprin1(x, cur_outp, 1); + lputc('\n', cur_outp); + } } + return UNSPECIFIED; } SCM quit(n) SCM n; @@ -1367,55 +1594,27 @@ SCM quit(n) 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); + ASSERT(execpath, UNSPECIFIED, s_no_execpath, s_unexec); *loc_errobj = newpath; longjump(CONT(rootcont)->jmpbuf, COOKIE(-4)); } @@ -1469,93 +1668,89 @@ void ints_warn(str1, str2, fname, linum) } #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 oloadports = loadports; SCM form, port; - port = open_file(filename, makfromstr("r", (sizet)sizeof(char))); + port = open_file(filename, makfromstr("r?", (sizet)2*sizeof(char))); if FALSEP(port) return port; *loc_loadpath = filename; - loadport = port; - linum = 1; + loadports = cons(port, loadports); while(1) { form = lread(port); if (EOF_VAL==form) break; SIDEVAL(form, EOL); } close_port(port); - linum = olninum; - loadport = oloadport; + loadports = oloadports; *loc_loadpath = oloadpath; } return BOOL_T; } -#endif #ifdef CAUTIOUS -static void trace1(estk, n) +static long num_frames(estk, i) SCM estk; - int n; + int i; { - 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); + long n = 0; + while NIMP(estk) { + n += (i - SCM_ESTK_BASE)/SCM_ESTK_FRLEN; + i = INUM(SCM_ESTK_PARENT_INDEX(estk)); + estk = SCM_ESTK_PARENT(estk); + } + return n; } +extern SCM scm_trace; 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; + SCM ste, lste, estk = scm_estk; + int i = (scm_estk_ptr - VELTS(scm_estk)); + int n, nf = num_frames(estk, i); + int ellip = 0, nbrk1 = 7, nbrk2 = nf - 5; + if (nf <= 0) return BOOL_F; + nf = 0; 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; + if (NIMP(scm_trace) && (scm_trace != scm_estk_ptr[2])) + if (reset_safeport(sys_safep, 65, cur_errp)) { + /* The usual C setjmp, not SCM's setjump. */ + if (0==setjmp(SAFEP_JMPBUF(sys_safep))) { + lputs("\n+; ", sys_safep); + iprin1(scm_trace, sys_safep, 1); + } + } + lste = UNDEFINED; + while NIMP(estk) { + n = (i - SCM_ESTK_BASE)/SCM_ESTK_FRLEN; + for (; n > 0; n--) { + if (nf <= nbrk1 || nf >= nbrk2) { + ste = VELTS(estk)[SCM_ESTK_BASE + n*SCM_ESTK_FRLEN + 2]; + if (ste != lste) { + lste = ste; + if (reset_safeport(sys_safep, 65, cur_errp)) { + /* The usual C setjmp, not SCM's setjump. */ + if (0==setjmp(SAFEP_JMPBUF(sys_safep))) { + lputc('\n', cur_errp); + intprint(nf, -10, sys_safep); + lputs("; ", sys_safep); + iprin1(ste, sys_safep, 1); + } + } + else if (! ellip++) + lputs("\n...", cur_errp); + } + } + nf++; + } + i = INUM(SCM_ESTK_PARENT_INDEX(estk)); + estk = SCM_ESTK_PARENT(estk); } - do { - trace1(scm_estk, n); - } while (--n > 0); + lputc('\n', cur_errp); return BOOL_T; } #endif @@ -1563,25 +1758,28 @@ SCM scm_stack_trace() static void err_head(str) char *str; { + SCM lps; 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); + for (lps = loadports; NIMP(lps); lps = CDR(lps)) { + if (lps != loadports) + lputs("\n ;loaded from ", cur_errp); + iprin1(scm_port_filename(CAR(lps)), cur_errp, 1); lputs(", line ", cur_errp); - intprint((long)linum, 10, cur_errp); + iprin1(scm_port_line(CAR(lps)), cur_errp, 1); lputs(": ", cur_errp); } + if (NIMP(loadports) && NIMP(CDR(loadports))) + lputs("\n;", cur_errp); lfflush(cur_errp); errno = oerrno; - if (cur_errp==def_errp) { - if (errno>0) perror(str); - fflush(stderr); - return; - } + /* if (NIMP(cur_errp) && stderr==STREAM(cur_errp)) { ... } */ + if (errno>0) perror(str); + fflush(stderr); } -void warn(str1, str2) +void scm_warn(str1, str2) char *str1, *str2; { err_head("WARNING"); @@ -1614,56 +1812,67 @@ SCM lperror(arg) } static void def_err_response() { - SCM obj = *loc_errobj; + SCM env = err_env, obj = *loc_errobj; DEFER_INTS; + if (errjmp_recursive++) { + lputs("RECURSIVE ERROR: ", def_errp); + if (TYP16(cur_errp)==tc16_sfport) { + cur_errp = def_errp; + errjmp_recursive = 0; + lputs("reverting to default error port\n", def_errp); + } + else exit(EXIT_FAILURE); + } err_head("ERROR"); - lputs("ERROR: ", cur_errp); if (err_s_subr && *err_s_subr) { + lputs("ERROR: ", cur_errp); lputs(err_s_subr, cur_errp); lputs(": ", cur_errp); } + if (!err_pos) return; /* Already been printed */ 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) { + else if (WNA > (short)err_pos) { lputs("Wrong type in arg", cur_errp); - lputc(err_pos ? '0'+(short)err_pos : ' ', cur_errp); + lputc((short)err_pos <= ARGn ? ' ' : '1' + (short)err_pos - ARG1, cur_errp); } #else if ((~0x1fL) & (long)err_pos) lputs(err_pos, cur_errp); - else if (WNA>(long)err_pos) { + else if (WNA > (long)err_pos) { lputs("Wrong type in arg", cur_errp); - lputc(err_pos ? '0'+(int)err_pos : ' ', cur_errp); + lputc((long)err_pos <= ARGn ? ' ' : '1' + (int)err_pos - ARG1, 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 + else lputs(errmsgs[((int)err_pos)-WNA].msg, cur_errp); + lputs(((long)err_pos==WNA)?" given ":" ", cur_errp); + err_pos = 0; + if (!UNBNDP(obj)) + if (reset_safeport(sys_safep, 55, cur_errp)) + if (0==setjmp(SAFEP_JMPBUF(sys_safep))) + iprin1(obj, sys_safep, 1); 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 (reset_safeport(sys_safep, 55, cur_errp)) + if (0==setjmp(SAFEP_JMPBUF(sys_safep))) { + lputs("\n; in expression: ", cur_errp); + if NCONSP(err_exp) + iprin1(err_exp, sys_safep, 1); + else if (UNDEFINED==CDR(err_exp)) + iprin1(CAR(err_exp), sys_safep, 1); + else iprlist("(... ", err_exp, ')', sys_safep, 1); + } } - if NULLP(err_env) lputs("\n; in top level environment.", cur_errp); + if (NIMP(env) && ENVP(env)) { + if (scm_env==env) { + lputs("\n; in expand-time environment: ", cur_errp); + iprin1(env, cur_errp, 1); + } + env = CDR(env); + } + if (NULLP(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); @@ -1673,15 +1882,17 @@ outobj: } } getout: +#ifdef CAUTIOUS + scm_stack_trace(); +#endif 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); + lputs("\nFATAL ERROR DURING CRITICAL CODE SECTION: ", cur_errp); + lputs(errjmp_bad, cur_errp); + lputc('\n', cur_errp); lroom(BOOL_T); - lputs("\nFATAL ERROR DURING CRITICAL CODE SECTION\n", cur_errp); #ifdef vms exit(EXIT_FAILURE); #else @@ -1700,13 +1911,10 @@ void everr(exp, env, arg, pos, s_subr) *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)); + if (errjmp_bad || errjmp_recursive) def_err_response(); + longjump(CONT(rootcont)->jmpbuf, + (~0x1fL) & (long)pos || (WNA > (long)pos) ? + COOKIE(1) : COOKIE((int)pos)); /* will do error processing at stack base */ } void wta(arg, pos, s_subr) @@ -1733,25 +1941,34 @@ 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); + SCM oinp; + ASSERT(NIMP(port) && INPORTP(port), port, ARG1, s_cur_inp); + DEFER_INTS; + oinp = cur_inp; cur_inp = port; + ALLOW_INTS; return oinp; } SCM set_outp(port) SCM port; { - SCM ooutp = cur_outp; - ASSERT(NIMP(port) && OPOUTPORTP(port), port, ARG1, s_cur_outp); + SCM ooutp; + ASSERT(NIMP(port) && OUTPORTP(port), port, ARG1, s_cur_outp); + DEFER_INTS; + ooutp = cur_outp; cur_outp = port; + ALLOW_INTS; return ooutp; } SCM set_errp(port) SCM port; { - SCM oerrp = cur_errp; - ASSERT(NIMP(port) && OPOUTPORTP(port), port, ARG1, s_cur_errp); + SCM oerrp; + ASSERT(NIMP(port) && OUTPORTP(port), port, ARG1, s_cur_errp); + DEFER_INTS; + oerrp = cur_errp; cur_errp = port; + ALLOW_INTS; return oerrp; } static char s_isatty[] = "isatty?"; @@ -1767,7 +1984,6 @@ 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}, @@ -1781,7 +1997,6 @@ 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}, @@ -1790,6 +2005,9 @@ static iproc subr1s[] = { {s_tryarb, tryarb}, {s_relarb, relarb}, {s_isatty, l_isatty}, + {s_port_line, scm_port_line}, + {s_port_col, scm_port_col}, + {s_port_filename, scm_port_filename}, {0, 0}}; static iproc subr1os[] = { @@ -1797,15 +2015,12 @@ static iproc subr1os[] = { {s_read_char, scm_read_char}, {s_peek_char, peek_char}, {s_newline, newline}, + {s_freshline, scm_freshline}, {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}}; @@ -1827,17 +2042,15 @@ void init_repl( 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; + loc_readsharp = &CDR(sysintern("read:sharp", UNDEFINED)); + loc_readsharpc = &CDR(sysintern("read:sharp-char", UNDEFINED)); 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 + make_subr(s_wfi, tc7_lsubr, wait_for_input); #ifdef CAN_DUMP add_feature("dump"); scm_ldstr("\ @@ -1860,8 +2073,5 @@ void final_repl() { loc_errobj = (SCM *)&tmp_errobj; loc_loadpath = (SCM *)&tmp_loadpath; - loadport = UNDEFINED; - transcript = BOOL_F; - trans = 0; - linum = 1; + loadports = EOL; } |