From deda2c0fd8689349fea2a900199a76ff7ecb319e Mon Sep 17 00:00:00 2001 From: Bryan Newbold Date: Mon, 20 Feb 2017 00:05:26 -0800 Subject: Import Upstream version 5d6 --- repl.c | 647 ++++++++++++++++++++++++++++++++++++++++------------------------- 1 file changed, 395 insertions(+), 252 deletions(-) (limited to 'repl.c') diff --git a/repl.c b/repl.c index 20be8b1..ae7642f 100644 --- a/repl.c +++ b/repl.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1990-1999 Free Software Foundation, Inc. +/* Copyright (C) 1990-2002 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 @@ -15,26 +15,26 @@ * 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. + * for additional uses of the text contained in its release of SCM. * - * The exception is that, if you link the GUILE library with other files + * The exception is that, if you link the SCM library with other files * to produce an executable, this does not by itself cause the * resulting executable to be covered by the GNU General Public License. * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. + * linking the SCM library code into it. * * This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU General Public License. * * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy + * Free Software Foundation under the name SCM. If you copy * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does + * SCM, as the General Public License permits, the exception does * not apply to the code that you add in this way. To avoid misleading * anyone as to the status of such modified files, you must delete * this exception notice from them. * - * If you write modifications of your own for GUILE, it is your choice + * If you write modifications of your own for SCM, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ @@ -53,6 +53,15 @@ void scm_fill_freelist P((void)); # include #endif +#ifdef __OpenBSD__ +# include +# include +#endif + +#ifdef PLAN9 +# include +#endif + #ifdef ARM_ULIB # include int set_erase() @@ -62,7 +71,7 @@ int set_erase() ioctl(0, TCGETA, &tin); tin.c_cc[VERASE] = '\010'; - ioctl(0, TCSETA,&tin); + ioctl(0, TCSETA, &tin); return(0); } #endif @@ -122,8 +131,11 @@ char *isymnames[] = { /* NUM_ISPCSYMS ISPCSYMS here */ "#@and", "#@begin", "#@case", "#@cond", "#@do", "#@if", "#@lambda", "#@let", "#@let*", "#@letrec", "#@or", "#@quote", "#@set!", - "#@define", "#@apply", "#@farloc-car", "#@farloc-cdr", "#@delay", - "#@quasiquote", "#@unquote", "#@unquote-splicing", "#@else", "#@=>", + "#@funcall", "#@apply", "#@farloc-car", "#@farloc-cdr", "#@delay", + "#@quasiquote", "#@eval-for-apply", "#@let-syntax", "#@acro-call", + "#", "#@define", + "#@unquote", "#@unquote-splicing", "#@else", "#@=>", "#@values-token", + "#@keyword", /* user visible ISYMS */ /* other keywords */ /* Flags */ @@ -138,9 +150,13 @@ static char s_freshline[] = "freshline"; static char s_eofin[] = "end of file in "; static char s_unknown_sharp[] = "unknown # object"; -static SCM lreadr P((SCM tok_buf, SCM port)); -static SCM lreadparen P((SCM tok_buf, SCM port, char *name)); +static SCM lread1 P((SCM port, int nump, char *what)); +static SCM lreadr P((SCM tok_buf, SCM port, int nump)); +static SCM lreadpr P((SCM tok_buf, SCM port, int nump)); +static SCM lreadparen P((SCM tok_buf, SCM port, int nump, char *name)); +static SCM lread_rec P((SCM tok_buf, SCM port)); static sizet read_token P((int ic, SCM tok_buf, SCM port)); +static void err_head P((char *str)); void intprint(n, radix, port) long n; @@ -196,7 +212,7 @@ void iprlist(hdr, exp, tlr, port, writing) void iprin1(exp, port, writing) SCM exp; SCM port; -int writing; + int writing; { register long i; taloop: @@ -219,6 +235,11 @@ taloop: intprint(i, -8, port); else lputc((int)i, port); } + else if (SCM_LINUMP(exp)) { + lputs("#', port); + } else if (IFLAGP(exp) && (ISYMNUM(exp)<(sizeof isymnames/sizeof(char *)))) lputs(ISYMCHARS(exp), port); else if ILOCP(exp) { @@ -247,14 +268,29 @@ taloop: break; } switch TYP7(exp) { + case (127 & IM_LET): + if (CAR(exp) != IM_LET) { + lputs("(#@call ", port); + exp = CDR(exp); + iprin1(CAR(exp), port, writing); + iprlist(" ", CAR(CDR(exp)), ')', port, writing); + break; + } + /* else fall through */ + case (127 & IM_AND): case (127 & IM_BEGIN): case (127 & IM_CASE): + case (127 & IM_COND): case (127 & IM_DO): case (127 & IM_IF): + case (127 & IM_LAMBDA): case (127 & IM_LETSTAR): + case (127 & IM_LETREC): case (127 & IM_OR): case (127 & IM_QUOTE): + case (127 & IM_SET): case (127 & IM_FUNCALL): + case tcs_cons_inum: + case tcs_cons_iloc: + case tcs_cons_chflag: case tcs_cons_gloc: - case tcs_cons_imcar: case tcs_cons_nimcar: iprlist("(", exp, ')', port, writing); break; case tcs_closures: - exp = CODE(exp); - iprlist("#', port, writing); + scm_princlosure(exp, port, writing); break; case tc7_string: if (writing) { @@ -363,7 +399,9 @@ static int input_waiting(f) # else # ifndef macintosh # ifndef ARM_ULIB -# include +# ifndef PLAN9 +# include +# endif # endif # endif # endif @@ -408,7 +446,7 @@ SCM char_readyp(port) SCM port; { if UNBNDP(port) port = cur_inp; - else ASSERT(NIMP(port) && OPINPORTP(port), port, ARG1, s_char_readyp); + ASSERT(NIMP(port) && OPINPORTP(port), port, ARG1, s_char_readyp); if (CRDYP(port) || !(BUF0 & SCM_PORTFLAGS(port))) return BOOL_T; return input_waiting(STREAM(port)) ? BOOL_T : BOOL_F; } @@ -417,7 +455,11 @@ SCM char_readyp(port) # include #endif #ifndef HAVE_SELECT -# include +# ifdef PLAN9 +# define kbhit() 0 +# else +# include +# endif #endif #ifdef __STDC__ # define timet time_t @@ -520,11 +562,46 @@ SCM eof_objectp(x) return (EOF_VAL==x) ? BOOL_T : BOOL_F; } +static SCM *loc_broken_pipe = 0; +/* returning non-zero means try again. */ +int scm_io_error(port, what) + SCM port; + char *what; +{ +#ifdef HAVE_PIPE +# ifdef EPIPE + if (EPIPE==errno) { + if (verbose > 2) { + err_head("WARNING"); + lputs(";;", cur_errp); + lputs(what, cur_errp); + lputs(": closing pipe ", cur_errp); + iprin1(port, cur_errp, 1); + newline(cur_errp); + } + close_port(port); + if (*loc_broken_pipe && NIMP(*loc_broken_pipe)) + apply(*loc_broken_pipe, port, listofnull); + return 0; + } +# endif +#endif + if (SCM_INTERRUPTED(errno)) { + errno = 0; + return !0; + } + wta(port, what, "Input/Output"); + return 0; /* squelch warning */ +} + +static char s_fflush[] = "fflush"; void lfflush(port) /* internal SCM call */ SCM port; { sizet i = PTOBNUM(port); - (ptobs[i].fflush)(STREAM(port)); + while ((ptobs[i].fflush)(STREAM(port)) && + scm_io_error(port, s_fflush)) + ; } static char s_flush[] = "force-output"; SCM lflush(port) /* user accessible as force-output */ @@ -534,7 +611,9 @@ SCM lflush(port) /* user accessible as force-output */ else ASSERT(NIMP(port) && OPOUTPORTP(port), port, ARG1, s_flush); { sizet i = PTOBNUM(port); - SYSCALL((ptobs[i].fflush)(STREAM(port));); + while ((ptobs[i].fflush)(STREAM(port)) && + scm_io_error(port, s_fflush)) + ; return UNSPECIFIED; } } @@ -545,11 +624,6 @@ SCM lwrite(obj, port) if UNBNDP(port) port = cur_outp; else ASSERT(NIMP(port) && OPOUTPORTP(port), port, ARG2, s_write); iprin1(obj, port, 1); -#ifdef HAVE_PIPE -# ifdef EPIPE - if (EPIPE==errno) close_port(port); -# endif -#endif return UNSPECIFIED; } SCM display(obj, port) @@ -558,11 +632,6 @@ SCM display(obj, port) if UNBNDP(port) port = cur_outp; else ASSERT(NIMP(port) && OPOUTPORTP(port), port, ARG2, s_display); iprin1(obj, port, 0); -#ifdef HAVE_PIPE -# ifdef EPIPE - if (EPIPE==errno) close_port(port); -# endif -#endif return UNSPECIFIED; } SCM newline(port) @@ -571,13 +640,7 @@ SCM newline(port) if UNBNDP(port) port = cur_outp; else ASSERT(NIMP(port) && OPOUTPORTP(port), port, ARG1, s_newline); lputc('\n', port); -#ifdef HAVE_PIPE -# ifdef EPIPE - if (EPIPE==errno) close_port(port); - else -# endif -#endif - if (port==cur_outp) lfflush(port); + if (port==cur_outp) lfflush(port); return UNSPECIFIED; } SCM write_char(chr, port) @@ -587,11 +650,6 @@ SCM write_char(chr, port) else ASSERT(NIMP(port) && OPOUTPORTP(port), port, ARG2, s_write_char); ASSERT(ICHRP(chr), chr, ARG1, s_write_char); lputc((int)ICHR(chr), port); -#ifdef HAVE_PIPE -# ifdef EPIPE - if (EPIPE==errno) close_port(port); -# endif -#endif return UNSPECIFIED; } SCM scm_freshline(port) @@ -601,13 +659,7 @@ SCM scm_freshline(port) 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); + if (port==cur_outp) lfflush(port); return UNSPECIFIED; } @@ -616,13 +668,15 @@ void lputc(c, port) SCM port; { sizet i = PTOBNUM(port); - SYSCALL((ptobs[i].fputc)(c, STREAM(port));); + while (EOF==(ptobs[i].fputc)(c, STREAM(port)) && + scm_io_error(port, "fputc")) + ; if (CRDY & CAR(port)) { i = SCM_PORTNUM(port); switch (c) { case LINE_INCREMENTORS: scm_port_table[i].line++; - scm_port_table[i].col = 0; + scm_port_table[i].col = 1; break; default: scm_port_table[i].col++; @@ -635,7 +689,9 @@ void lputs(s, port) { sizet i = PTOBNUM(port); ASSERT(s, INUM0, ARG1, "lputs"); - SYSCALL((ptobs[i].fputs)(s, STREAM(port));); + while (EOF==(ptobs[i].fputs)(s, STREAM(port)) && + scm_io_error(port, "fputs")) + ; if (CRDY & CAR(port)) { sizet j; i = SCM_PORTNUM(port); @@ -643,7 +699,7 @@ void lputs(s, port) switch (s[j]) { case LINE_INCREMENTORS: scm_port_table[i].line++; - scm_port_table[i].col = 0; + scm_port_table[i].col = 1; break; default: scm_port_table[i].col++; @@ -658,8 +714,9 @@ sizet lfwrite(ptr, size, nitems, port) SCM port; { sizet ret, i = PTOBNUM(port); - SYSCALL(ret = (ptobs[i].fwrite) - (ptr, size, nitems, STREAM(port));); + do { + ret = (ptobs[i].fwrite)(ptr, size, nitems, STREAM(port)); + } while(nitems != ret && scm_io_error(port, "fwrite")); if (CRDY & CAR(port)) { sizet j; i = SCM_PORTNUM(port); @@ -667,7 +724,7 @@ sizet lfwrite(ptr, size, nitems, port) switch (ptr[j]) { case LINE_INCREMENTORS: scm_port_table[i].line++; - scm_port_table[i].col = 0; + scm_port_table[i].col = 1; break; default: scm_port_table[i].col++; @@ -682,7 +739,7 @@ int lgetc(port) { FILE *f; int c; - sizet i, j; + int i, j = -1; if (CRDY & CAR(port)) { j = SCM_PORTNUM(port); c = scm_port_table[j].unread; @@ -699,12 +756,13 @@ int lgetc(port) #else SYSCALL(c = (ptobs[i].fgetc)(f);); #endif - if (CRDY & CAR(port)) { /* CRDY overloaded !!*/ + if (j > -1) { + /* This means that CRDY is set, note that CRDY is 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; + scm_port_table[j].col = 1; break; default: scm_port_table[j].col++; @@ -716,9 +774,14 @@ void lungetc(c, port) int c; SCM port; { + int i = PTOBNUM(port); /* ASSERT(!CRDYP(port), port, ARG2, "too many lungetc");*/ - scm_port_table[SCM_PORTNUM(port)].unread = c; - CAR(port) |= CRDY; + if (ptobs[i].ungetc) + (ptobs[i].ungetc)(c, port); + else { + scm_port_table[SCM_PORTNUM(port)].unread = c; + CAR(port) |= CRDY; + } } SCM scm_read_char(port) @@ -726,7 +789,7 @@ SCM scm_read_char(port) { int c; if UNBNDP(port) port = cur_inp; - else ASSERT(NIMP(port) && OPINPORTP(port), port, ARG1, s_read_char); + ASSERT(NIMP(port) && OPINPORTP(port), port, ARG1, s_read_char); c = lgetc(port); if (EOF==c) return EOF_VAL; return MAKICHR(c); @@ -771,27 +834,37 @@ static int flush_ws(port) } SCM lread(port) SCM port; +{ + return lread1(port, 0, s_read); +} +static SCM lread1(port, nump, what) + SCM port; + int nump; + char *what; { int c; SCM tok_buf; if UNBNDP(port) port = cur_inp; - else ASSERT(NIMP(port) && OPINPORTP(port), port, ARG1, s_read); + ASSERT(NIMP(port) && OPINPORTP(port), port, ARG1, what); do { c = flush_ws(port); if (EOF==c) return EOF_VAL; lungetc(c, port); tok_buf = makstr(30L); - } while (EOF_VAL==(tok_buf = lreadr(tok_buf, port))); + } while (EOF_VAL==(tok_buf = lreadr(tok_buf, port, nump))); return tok_buf; } static SCM *loc_readsharp = 0, *loc_readsharpc = 0; -static SCM lreadpr(tok_buf, port) +static SCM lreadpr(tok_buf, port, nump) SCM tok_buf; SCM port; + int nump; { int c; sizet j; SCM p; + if (2==nump) + return lread_rec(tok_buf, port); tryagain: c = flush_ws(port); switch (c) { @@ -800,13 +873,15 @@ tryagain: case '[': #endif case '(': - return lreadparen(tok_buf, port, s_list); + return lreadparen(tok_buf, port, nump, s_list); #ifdef BRACKETS_AS_PARENS case ']': #endif case ')': return UNDEFINED; /* goto tryagain; */ - case '\'': return cons2(i_quote, lreadr(tok_buf, port), EOL); - case '`': return cons2(i_quasiquote, lreadr(tok_buf, port), EOL); + case '\'': return cons2(i_quote, + lreadr(tok_buf, port, nump), EOL); + case '`': return cons2(i_quasiquote, + lreadr(tok_buf, port, nump), EOL); case ',': c = lgetc(port); if ('@'==c) p = i_uq_splicing; @@ -814,7 +889,7 @@ tryagain: lungetc(c, port); p = i_unquote; } - return cons2(p, lreadr(tok_buf, port), EOL); + return cons2(p, lreadr(tok_buf, port, nump), EOL); case '#': c = lgetc(port); switch (c) { @@ -822,7 +897,7 @@ tryagain: case '[': #endif case '(': - p = lreadparen(tok_buf, port, s_vector); + p = lreadparen(tok_buf, port, nump, s_vector); return NULLP(p) ? nullvect : vector(p); case 't': case 'T': return BOOL_T; case 'f': case 'F': return BOOL_F; @@ -928,18 +1003,42 @@ tok: return CAR(p); } } -static SCM lreadr(tok_buf, port) +static SCM lreadr(tok_buf, port, nump) SCM tok_buf; SCM port; + int nump; { - SCM ans = lreadpr(tok_buf, port); + SCM ans = lreadpr(tok_buf, port, nump); switch (ans) { case UNDEFINED: - scm_warn("unexpected \")\"", ""); - return lreadpr(tok_buf, port); + scm_warn("unexpected \")\"", "", port); + return lreadpr(tok_buf, port, nump); } return ans; } +static SCM lread_rec(tok_buf, port) + SCM tok_buf; + SCM port; +{ + SCM line, form; + int c = flush_ws(port); + switch(c) { + default: + lungetc(c, port); + line = scm_port_line(port); + form = lreadpr(tok_buf, port, 1); + if (NFALSEP(line) && NIMP(form) && + (CONSP(form) || VECTORP(form))) { + return cons(SCM_MAKE_LINUM(INUM(line)), form); + } + return form; +#ifdef BRACKETS_AS_PARENS + case ']': +#endif + case ')': return UNDEFINED; + case EOF: return EOF_VAL; + } +} #ifdef _UNICOS _Pragma("noopt"); /* # pragma _CRI noopt */ @@ -977,25 +1076,26 @@ static sizet read_token(ic, tok_buf, port) _Pragma("opt"); /* # pragma _CRI opt */ #endif -static SCM lreadparen(tok_buf, port, name) +static SCM lreadparen(tok_buf, port, nump, name) SCM tok_buf; SCM port; + int nump; char *name; { - SCM lst, fst, tmp = lreadpr(tok_buf, port); + SCM lst, fst, tmp = lreadpr(tok_buf, port, nump ? 2 : 0); if (UNDEFINED==tmp) return EOL; if (i_dot==tmp) { - fst = lreadr(tok_buf, port); + fst = lreadr(tok_buf, port, nump ? 1 : 0); closeit: - tmp = lreadpr(tok_buf, port); + tmp = lreadpr(tok_buf, port, 0); if (UNDEFINED != tmp) wta(UNDEFINED, "missing close paren", name); return fst; } fst = lst = cons(tmp, EOL); - while (UNDEFINED != (tmp = lreadpr(tok_buf, port))) { + while (UNDEFINED != (tmp = lreadpr(tok_buf, port, nump ? 2 : 0))) { if (EOF_VAL==tmp) wta(lst, s_eofin, s_list); if (i_dot==tmp) { - CDR(lst) = lreadr(tok_buf, port); + CDR(lst) = lreadr(tok_buf, port, nump ? 1 : 0); goto closeit; } lst = (CDR(lst) = cons(tmp, EOL)); @@ -1006,6 +1106,18 @@ static SCM lreadparen(tok_buf, port, name) /* These procedures implement synchronization primitives. Processors with an atomic test-and-set instruction can use it here (and not DEFER_INTS). */ +char s_swapcar[] = "swap-car!"; +SCM swapcar(pair, value) + SCM pair, value; +{ + SCM ret; + ASSERT(NIMP(pair) && CONSP(pair), pair, ARG1, s_swapcar); + DEFER_INTS; + ret = CAR(pair); + CAR(pair) = value; + ALLOW_INTS; + return ret; +} char s_tryarb[] = "try-arbiter"; char s_relarb[] = "release-arbiter"; long tc16_arbiter; @@ -1074,16 +1186,17 @@ struct errdesc errmsgs[] = { void (* deferred_proc) P((void)) = 0; 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; -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; int scm_verbose = 1; /* Low so that monitor info won't be */ /* printed while in init_storage. (BOOM) */ +static int errjmp_recursive = 0; +static int errobj_codep; +static SCM err_exp, err_env; +static char *err_pos, *err_s_subr; +static cell tmp_errobj = {(SCM)UNDEFINED, (SCM)EOL}; +static cell tmp_loadpath = {(SCM)BOOL_F, (SCM)EOL}; +SCM *loc_errobj = (SCM *)&tmp_errobj; +SCM *loc_loadpath = (SCM *)&tmp_loadpath; long cells_allocated = 0, lcells_allocated = 0, mallocated = 0, lmallocated = 0, rt = 0, gc_rt, gc_time_taken; @@ -1113,6 +1226,7 @@ int handle_it(i) 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 @@ -1142,23 +1256,35 @@ int handle_it(i) } static char s_eval_string[] = "eval-string"; static char s_load_string[] = "load-string"; +static SCM i_eval_string = 0; SCM scm_eval_string(str) SCM str; { + SCM env = EOL; +#ifdef SCM_ENV_FILENAME + if (i_eval_string) + env = scm_env_addprop(SCM_ENV_FILENAME, i_eval_string, env); +#endif str = mkstrport(INUM0, str, OPN | RDNG, s_eval_string); str = lread(str); - return EVAL(str, (SCM)EOL); + return EVAL(str, env, EOL); } +static SCM i_load_string = 0; SCM scm_load_string(str) SCM str; { + SCM env = EOL; +#ifdef SCM_ENV_FILENAME + if (i_load_string) + env = scm_env_addprop(SCM_ENV_FILENAME, i_load_string, env); +#endif ASSERT(NIMP(str) && (STRINGP(str) || SYMBOLP(str)), str, ARG1, s_load_string); str = mkstrport(INUM0, str, OPN | RDNG, s_load_string); while(1) { SCM form = lread(str); if (EOF_VAL==form) break; - SIDEVAL(form, EOL); + SIDEVAL(form, env, EOL); } return BOOL_T; } @@ -1191,10 +1317,10 @@ SCM scm_top_level(initpath, toplvl_fun) SCM proc = CDR(intern(name, (sizet)strlen(name))); if NIMP(proc) apply(proc, EOL, EOL); }} - if ((i = errmsgs[i-WNA].parent_err)) goto drloop; + i = errmsgs[i-WNA].parent_err; + if (i) goto drloop; case 1: /* from everr() */ def_err_response(); - dowinds(EOL); goto reset_toplvl; case 0: exitval = MAKINUM(EXIT_SUCCESS); @@ -1205,6 +1331,7 @@ SCM scm_top_level(initpath, toplvl_fun) SIG_deferred = 0; deferred_proc = 0; ints_disabled = 0; + scm_init_INITS(); if (dumped) { lcells_allocated = cells_allocated; lmallocated = mallocated; @@ -1224,13 +1351,13 @@ SCM scm_top_level(initpath, toplvl_fun) } case -2: /* abrt */ reset_toplvl: - dowinds(EOL); ints_disabled = 1; errjmp_bad = (char *)0; errjmp_recursive = 0; lflush(sys_errp); SIG_deferred = 0; deferred_proc = 0; + gc_hook_active = 0; scm_estk_reset(0); /* Closing the loading file turned out to be a bad idea. */ @@ -1249,12 +1376,12 @@ SCM scm_top_level(initpath, toplvl_fun) *loc_loadpath = BOOL_F; loadports = EOL; ints_disabled = 0; + dowinds(EOL); 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) { @@ -1301,6 +1428,7 @@ SCM scm_port_line(port) lnum = scm_port_table[SCM_PORTNUM(port)].line; switch (CGETUN(port)) { default: + case EOF: /* no ungetted char */ break; case LINE_INCREMENTORS: lnum--; @@ -1312,7 +1440,7 @@ static char s_port_col[] = "port-column"; SCM scm_port_col(port) SCM port; { - short col; + long 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; @@ -1320,6 +1448,8 @@ SCM scm_port_col(port) default: col--; break; + case EOF: /* no ungetted char */ + break; case LINE_INCREMENTORS: col = scm_port_table[SCM_PORTNUM(port)].colprev; break; @@ -1344,15 +1474,13 @@ SCM prog_args() } extern char s_heap[]; -extern sizet hplim_ind; -extern CELLPTR *hplims; void growth_mon(obj, size, units, grewp) char *obj; long size; char *units; int grewp; { - if (verbose>2) + if (verbose > 2) { lputs((grewp ? "; grew " : "; shrank "), sys_errp); lputs(obj, sys_errp); @@ -1360,18 +1488,18 @@ void growth_mon(obj, size, units, grewp) intprint(size, -10, sys_errp); lputc(' ', sys_errp); lputs(units, sys_errp); - if ((verbose>4) && (obj==s_heap)) heap_report(); - lputs("\n", sys_errp); + if ((verbose > 4) && (obj==s_heap)) heap_report(); + lputs("\n; ", sys_errp); } } void gc_start(what) char *what; { - if (verbose>3 && FPORTP(cur_errp)) { + if (verbose > 4) { lputs(";GC(", sys_errp); lputs(what, sys_errp); - lputs(")", sys_errp); + lputs(") ", sys_errp); } scm_gcs++; gc_rt = INUM(my_time()); @@ -1384,10 +1512,9 @@ void gc_end() { gc_rt = INUM(my_time()) - gc_rt; gc_time_taken = gc_time_taken + gc_rt; - if (verbose>3) { - if (!FPORTP(cur_errp)) lputs(";GC ", sys_errp); + if (verbose > 4) { intprint(time_in_msec(gc_rt), -10, sys_errp); - lputs(" cpu mSec, ", sys_errp); + lputs(".ms cpu, ", sys_errp); intprint(gc_cells_collected, -10, sys_errp); lputs(" cells, ", sys_errp); intprint(gc_malloc_collected, -10, sys_errp); @@ -1410,21 +1537,21 @@ void scm_egc_end() } void repl_report() { - if (verbose>1) { + if (verbose > 2) { lfflush(cur_outp); lputs(";Evaluation took ", cur_errp); intprint(time_in_msec(INUM(my_time())-rt), -10, cur_errp); - lputs(" mSec (", cur_errp); + lputs(".ms (", cur_errp); intprint(time_in_msec(gc_time_taken), -10, cur_errp); - lputs(" in gc) ", cur_errp); + lputs(".ms in gc) ", cur_errp); intprint(cells_allocated - lcells_allocated, -10, cur_errp); lputs(" cells work, ", cur_errp); scm_env_work += scm_ecache_len - scm_ecache_index; intprint(scm_env_work, -10, cur_errp); lputs(" env, ", cur_errp); intprint(mallocated - lmallocated, -10, cur_errp); - lputs(" bytes other\n", cur_errp); - if (verbose>2) { + lputs(".B other\n", cur_errp); + if (verbose > 3) { lputc(';', cur_errp); intprint(scm_gcs, -10, cur_errp); lputs( " gc, ", cur_errp); @@ -1449,7 +1576,7 @@ void init_sbrk() } void scm_brk_report() { - unsigned long scm_curbrk = sbrk(0), + unsigned long scm_curbrk = (unsigned long)sbrk(0), dif1 = ((dumped ? scm_dumped_brk : scm_curbrk) - scm_init_brk)/1024, dif2 = (scm_curbrk - scm_dumped_brk)/1024; @@ -1464,10 +1591,10 @@ void scm_brk_report() lputs("; ", cur_errp); intprint(dif1, 10, cur_errp); if (dumped) { - lputs(dif2<0 ? " - " : " + ", cur_errp); - intprint(dif2<0 ? -dif2 : dif2, 10, cur_errp); + lputs(dif2 < 0 ? " - " : " + ", cur_errp); + intprint(dif2 < 0 ? -dif2 : dif2, 10, cur_errp); } - lputs(" kb\n", cur_errp); + lputs(".kiB\n", cur_errp); } #endif SCM lroom(opt) @@ -1478,7 +1605,7 @@ SCM lroom(opt) intprint(heap_cells, -10, cur_errp); lputs(" cells in use, ", cur_errp); intprint(mallocated, -10, cur_errp); - lputs(" bytes allocated (of ", cur_errp); + lputs(".B allocated (of ", cur_errp); intprint(mtrigger, 10, cur_errp); lputs(")\n", cur_errp); if (!UNBNDP(opt)) { @@ -1486,30 +1613,12 @@ SCM lroom(opt) if (scm_init_brk) scm_brk_report(); #endif scm_ecache_report(); - heap_report(); - lputc('\n', cur_errp); + heap_report(); lputc('\n', cur_errp); + gra_report(); stack_report(); } return UNSPECIFIED; } -void heap_report() -{ - sizet i = 0; - lputs(";; heap segments:", sys_errp); - while(i < hplim_ind) { - { - long seg_cells = CELL_DN(hplims[i+1]) - CELL_UP(hplims[i]); - lputs("\n; 0x", sys_errp); - intprint((long)hplims[i++], -16, sys_errp); - lputs(" - 0x", sys_errp); - intprint((long)hplims[i++], -16, sys_errp); - lputs("; ", sys_errp); - intprint(seg_cells, 10, sys_errp); - lputs(" cells; ", sys_errp); - intprint(seg_cells / (1024 / sizeof(CELLPTR)), 10, sys_errp); - lputs(" kb", sys_errp); - }} -} void scm_ecache_report() { intprint(scm_estk_size, 10 , cur_errp); @@ -1521,12 +1630,12 @@ void scm_ecache_report() } void exit_report() { - if (verbose>2) { + if (verbose > 2) { lputs(";Totals: ", cur_errp); intprint(time_in_msec(INUM(my_time())), -10, cur_errp); - lputs(" mSec my time, ", cur_errp); + lputs(".ms my time, ", cur_errp); intprint(time_in_msec(INUM(your_time())), -10, cur_errp); - lputs(" mSec your time\n", cur_errp); + lputs(".ms your time\n", cur_errp); } } @@ -1541,11 +1650,13 @@ SCM prolixity(arg) return MAKINUM(old); } +static SCM i_repl; SCM repl() { SCM x; + SCM env = EOL; /* scm_env_addprop(SCM_ENV_FILENAME, i_repl, EOL); */ int c; - if OPINPORTP(cur_inp) { + if (OPINPORTP(cur_inp) && OPOUTPORTP(cur_outp)) { repl_report(); while(1) { if OPOUTPORTP(cur_inp) { /* This case for curses window */ @@ -1579,10 +1690,27 @@ SCM repl() {lfflush(cur_outp); newline(cur_inp);} else newline(cur_outp); #endif - x = EVAL(x, (SCM)EOL); + if (NIMP(x)) { + x = CONSP(x) ? + scm_eval_values(x, env, (SCM)EOL) : + cons(EVAL(x, env, (SCM)EOL), EOL); + } + else + x = cons(x, EOL); repl_report(); - iprin1(x, cur_outp, 1); - lputc('\n', cur_outp); + if (IMP(x)) + {if (verbose > 2) lputs(";;no values\n", cur_outp);} + else if (IMP(CDR(x))) { + iprin1(CAR(x), cur_outp, 1); + lputc('\n', cur_outp); + } + else + while (NIMP(x)) { + lputc(' ', cur_outp); + iprin1(CAR(x), cur_outp, 1); + lputc('\n', cur_outp); + x = CDR(x); + } } } return UNSPECIFIED; @@ -1623,10 +1751,10 @@ SCM scm_unexec(newpath) #ifdef CAREFUL_INTS ints_infot *ints_info = 0; static void ints_viol_iprin(num) - long num; + int num; { char num_buf[INTBUFLEN]; - sizet i = iint2str(num, 10, num_buf); + sizet i = iint2str(num+0L, 10, num_buf); num_buf[i] = 0; fputs(num_buf, stderr); } @@ -1640,7 +1768,7 @@ void ints_viol(info, sense) fputs(": ints already ", stderr); fputs(sense ? "dis" : "en", stderr); fputs("abled (", stderr); - ints_viol_iprin((long)ints_disabled); + ints_viol_iprin(ints_disabled); fputs(")\n", stderr); if (ints_info) { fputs(ints_info->fname, stderr); @@ -1657,7 +1785,7 @@ void ints_warn(str1, str2, fname, linum) fputs(fname, stderr); fputc(':', stderr); ints_viol_iprin(linum); - fputs(" :uprotected call to ", stderr); + fputs(": unprotected call to ", stderr); fputs(str1, stderr); if (str2) { fputs(" (", stderr); @@ -1668,22 +1796,43 @@ void ints_warn(str1, str2, fname, linum) } #endif -SCM tryload(filename) - SCM filename; +#ifdef CAUTIOUS +static SCM f_read_numbered; +static char s_read_numbered[] = "read-numbered"; +SCM scm_read_numbered(port) + SCM port; +{ + return lread1(port, 2, s_read_numbered); +} +#endif + +SCM tryload(filename, reader) + SCM filename, reader; { ASSERT(NIMP(filename) && STRINGP(filename), filename, ARG1, s_load); + if (FALSEP(reader)) reader = UNDEFINED; +#ifndef RECKLESS + if (!UNBNDP(reader)) scm_arity_check(reader, 1L, s_load); +#endif { SCM oloadpath = *loc_loadpath; SCM oloadports = loadports; SCM form, port; + SCM env = EOL; port = open_file(filename, makfromstr("r?", (sizet)2*sizeof(char))); if FALSEP(port) return port; *loc_loadpath = filename; loadports = cons(port, loadports); +#ifdef SCM_ENV_FILENAME + env = scm_env_addprop(SCM_ENV_FILENAME, filename, env); +#endif while(1) { - form = lread(port); + if (UNBNDP(reader)) + form = lread(port); + else + form = scm_cvapply(reader, 1L, &port); if (EOF_VAL==form) break; - SIDEVAL(form, EOL); + SIDEVAL(form, env, EOL); } close_port(port); loadports = oloadports; @@ -1692,68 +1841,34 @@ SCM tryload(filename) return BOOL_T; } -#ifdef CAUTIOUS -static long num_frames(estk, i) - SCM estk; - int i; +void scm_line_msg(file, linum, port) + SCM file, linum, port; { - 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); + iprin1(file, port, 1); + if (SCM_LINUMP(linum)) { + lputs(", line ", port); + intprint(SCM_LINUM(linum), -10, port); } - return n; -} - -extern SCM scm_trace; -SCM scm_stack_trace() -{ - 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); - 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++; + lputs(": ", port); +} +void scm_err_line(what, file, linum, port) + char *what; + SCM file, linum, port; +{ + lputs(what, port); + if (NIMP(file) && STRINGP(file)) + scm_line_msg(file, linum, port); +#ifdef CAUTIOUS + else { + SCM env = scm_env_getprop(SCM_ENV_FILENAME, scm_trace_env); + if (NIMP(env)) { + file = CAR(env); + scm_check_linum(scm_trace, &linum); + scm_line_msg(file, linum, port); } - i = INUM(SCM_ESTK_PARENT_INDEX(estk)); - estk = SCM_ESTK_PARENT(estk); } - lputc('\n', cur_errp); - return BOOL_T; -} #endif +} static void err_head(str) char *str; @@ -1761,11 +1876,10 @@ static void err_head(str) SCM lps; int oerrno = errno; exitval = MAKINUM(EXIT_FAILURE); - if NIMP(cur_outp) lfflush(cur_outp); - lputc('\n', cur_errp); + if (NIMP(cur_outp) && OPOUTPORTP(cur_outp)) lfflush(cur_outp); for (lps = loadports; NIMP(lps); lps = CDR(lps)) { - if (lps != loadports) - lputs("\n ;loaded from ", cur_errp); + lputs(lps==loadports ? "\n;While loading " : "\n ;loaded from ", + cur_errp); iprin1(scm_port_filename(CAR(lps)), cur_errp, 1); lputs(", line ", cur_errp); iprin1(scm_port_line(CAR(lps)), cur_errp, 1); @@ -1779,17 +1893,22 @@ static void err_head(str) if (errno>0) perror(str); fflush(stderr); } -void scm_warn(str1, str2) +void scm_warn(str1, str2, obj) char *str1, *str2; + SCM obj; { err_head("WARNING"); - lputs("WARNING: ", cur_errp); + scm_err_line("WARNING: ", UNDEFINED, UNDEFINED, cur_errp); lputs(str1, cur_errp); - if (str2) { + if (str2 && *str2) { lputs(str2, cur_errp); lputc('\n', cur_errp); - lfflush(cur_errp); } + if (!UNBNDP(obj)) { + iprin1(obj, cur_errp, 1); + lputc('\n', cur_errp); + } + lfflush(cur_errp); } SCM lerrno(arg) @@ -1812,25 +1931,41 @@ SCM lperror(arg) } static void def_err_response() { - SCM env = err_env, obj = *loc_errobj; + SCM file, env = err_env, obj = *loc_errobj; + SCM linum = UNDEFINED; + int badport = IMP(cur_errp) || !OPOUTPORTP(cur_errp); + int writing = 2; /* Value of 2 used only for printing error messages */ + int codep = errobj_codep; DEFER_INTS; - if (errjmp_recursive++) { + if (badport || (errjmp_recursive++)) { + if (IMP(def_errp) || !OPOUTPORTP(def_errp)) exit(EXIT_FAILURE); lputs("RECURSIVE ERROR: ", def_errp); - if (TYP16(cur_errp)==tc16_sfport) { + if (badport || TYP16(cur_errp)==tc16_sfport) { + lputs("reverting from ", def_errp); + iprin1(cur_errp, def_errp, 2); + lputs("to default error port\n", def_errp); cur_errp = def_errp; errjmp_recursive = 0; - lputs("reverting to default error port\n", def_errp); } else exit(EXIT_FAILURE); } +#ifdef SCM_ENV_FILENAME + file = scm_env_getprop(SCM_ENV_FILENAME, env); + if (NIMP(file)) file = CAR(file); + else file = UNDEFINED; +#else + file = BOOL_F; +#endif + if (codep) obj = scm_check_linum(obj, &linum); + err_exp = scm_check_linum(err_exp, UNBNDP(linum) ? &linum : 0L); err_head("ERROR"); + scm_err_line("ERROR: ", file, linum, 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; + if (err_pos==(char *)ARG1 && UNBNDP(obj)) err_pos = (char *)WNA; #ifdef nosve if ((~0x1fL) & (short)err_pos) lputs(err_pos, cur_errp); else if (WNA > (short)err_pos) { @@ -1850,40 +1985,26 @@ static void def_err_response() if (!UNBNDP(obj)) if (reset_safeport(sys_safep, 55, cur_errp)) if (0==setjmp(SAFEP_JMPBUF(sys_safep))) - iprin1(obj, sys_safep, 1); + if (codep) scm_princode(obj, EOL, sys_safep, writing); + else iprin1(obj, sys_safep, writing); if UNBNDP(err_exp) goto getout; if NIMP(err_exp) { 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); + if (NCONSP(err_exp)) scm_princode(err_exp, env, sys_safep, writing); else if (UNDEFINED==CDR(err_exp)) - iprin1(CAR(err_exp), sys_safep, 1); - else iprlist("(... ", err_exp, ')', sys_safep, 1); + iprin1(CAR(err_exp), sys_safep, writing); + else { + if (UNBNDP(env)) iprlist("(... ", err_exp, ')', sys_safep, writing); + else scm_princode(err_exp, env, sys_safep, writing); + } } } - 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 { - lputs("\n; in scope:", cur_errp); - while NNULLP(env) { - lputc('\n', cur_errp); - lputs("; ", cur_errp); - iprin1(CAR(CAR(env)), cur_errp, 1); - env = CDR(env); - } - } + scm_scope_trace(env); getout: #ifdef CAUTIOUS - scm_stack_trace(); + scm_stack_trace(UNDEFINED); #endif lputc('\n', cur_errp); lfflush(cur_errp); @@ -1902,15 +2023,17 @@ static void def_err_response() errno = 0; ALLOW_INTS; } -void everr(exp, env, arg, pos, s_subr) +void everr(exp, env, arg, pos, s_subr, codep) SCM exp, env, arg; char *pos, *s_subr; + int codep; { err_exp = exp; err_env = env; *loc_errobj = arg; err_pos = pos; err_s_subr = s_subr; + errobj_codep = codep; if (errjmp_bad || errjmp_recursive) def_err_response(); longjump(CONT(rootcont)->jmpbuf, (~0x1fL) & (long)pos || (WNA > (long)pos) ? @@ -1919,9 +2042,23 @@ void everr(exp, env, arg, pos, s_subr) } void wta(arg, pos, s_subr) SCM arg; -char *pos, *s_subr; + char *pos, *s_subr; { - everr(UNDEFINED, EOL, arg, pos, s_subr); +#ifndef RECKLESS + everr(scm_trace, scm_trace_env, arg, pos, s_subr, 0); +#else + everr(UNDEFINED, EOL, arg, pos, s_subr, 0); +#endif +} +void scm_experr(arg, pos, s_subr) + SCM arg; + char *pos, *s_subr; +{ +#ifndef RECKLESS + everr(scm_trace, scm_trace_env, arg, pos, s_subr, !0); +#else + everr(UNDEFINED, EOL, arg, pos, s_subr, !0); +#endif } SCM cur_input_port() { @@ -1988,16 +2125,12 @@ static iproc subr0s[] = { {"line-number", line_num}, {"abort", abrt}, {s_restart, restart}, -#ifdef CAUTIOUS - {"stack-trace", scm_stack_trace}, -#endif {0, 0}}; static iproc subr1s[] = { {s_cur_inp, set_inp}, {s_cur_outp, set_outp}, {s_cur_errp, set_errp}, - {s_tryload, tryload}, {s_load_string, scm_load_string}, {s_eval_string, scm_eval_string}, {s_perror, lperror}, @@ -2028,6 +2161,7 @@ static iproc subr2os[] = { {s_write, lwrite}, {s_display, display}, {s_write_char, write_char}, + {s_tryload, tryload}, #ifdef CAN_DUMP {s_unexec, scm_unexec}, #endif @@ -2040,17 +2174,26 @@ void init_repl( iverbose ) int iverbose; { sysintern(s_ccl, MAKINUM(CHAR_CODE_LIMIT)); + i_repl = CAR(sysintern("repl", UNDEFINED)); loc_errobj = &CDR(sysintern("errobj", UNDEFINED)); loc_loadpath = &CDR(sysintern("*load-pathname*", BOOL_F)); loc_readsharp = &CDR(sysintern("read:sharp", UNDEFINED)); loc_readsharpc = &CDR(sysintern("read:sharp-char", UNDEFINED)); + loc_broken_pipe = &CDR(sysintern("broken-pipe", 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); +#ifdef CAUTIOUS + f_read_numbered = + make_subr(s_read_numbered, tc7_subr_1, scm_read_numbered); +#endif add_feature(s_char_readyp); + make_subr(s_swapcar, tc7_subr_2, swapcar); make_subr(s_wfi, tc7_lsubr, wait_for_input); + i_eval_string = CAR(sysintern(s_eval_string, UNDEFINED)); + i_load_string = CAR(sysintern(s_load_string, UNDEFINED)); #ifdef CAN_DUMP add_feature("dump"); scm_ldstr("\ -- cgit v1.2.3