From c7d035ae1a729232579a0fe41ed5affa131d3623 Mon Sep 17 00:00:00 2001 From: Bryan Newbold Date: Mon, 20 Feb 2017 00:05:27 -0800 Subject: Import Upstream version 5d9 --- repl.c | 551 +++++++++++++++++++++++++++++++++++------------------------------ 1 file changed, 296 insertions(+), 255 deletions(-) (limited to 'repl.c') diff --git a/repl.c b/repl.c index ae7642f..07b357c 100644 --- a/repl.c +++ b/repl.c @@ -53,6 +53,11 @@ void scm_fill_freelist P((void)); # include #endif +#ifdef __NetBSD__ +# include +# include +#endif + #ifdef __OpenBSD__ # include # include @@ -143,17 +148,17 @@ char *isymnames[] = { }; static char s_read_char[] = "read-char", s_peek_char[] = "peek-char"; -char s_read[] = "read", s_write[] = "write", s_newline[] = "newline"; +char 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"; -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 lread1 P((SCM port, int flgs, char *what)); +static SCM lreadr P((SCM tok_buf, SCM port, int flgs)); +static SCM lreadpr P((SCM tok_buf, SCM port, int flgs)); +static SCM lreadparen P((SCM tok_buf, SCM port, int flgs, 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)); @@ -256,7 +261,12 @@ taloop: break; } lputs("#@", port); +#ifdef _M_ARM + /* MS CLARM compiler workaround */ + exp = CAR(MS_CLARM_dumy = exp - 1); +#else exp = CAR(exp-1); +#endif goto taloop; default: idef: @@ -427,7 +437,7 @@ static int input_waiting(f) tv.tv_usec = 0; SYSCALL(ret = select((fileno(f) + 1), &ifds, (fd_set *) NULL, (fd_set *) NULL, &tv);); - ASSERT(ret>=0, MAKINUM(ret), "select error", s_char_readyp); + ASRTER(ret>=0, MAKINUM(ret), "select error", s_char_readyp); return FD_ISSET(fileno(f), &ifds); # else # ifdef FIONREAD @@ -446,7 +456,7 @@ SCM char_readyp(port) SCM port; { if UNBNDP(port) port = cur_inp; - ASSERT(NIMP(port) && OPINPORTP(port), port, ARG1, s_char_readyp); + ASRTER(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; } @@ -472,7 +482,7 @@ SCM wait_for_input(args) { SCM how_long, port1, port, ports, ans = EOL; int timeout, pos = ARG2; - ASSERT(!NULLP(args), INUM0, WNA, s_wfi); + ASRTER(!NULLP(args), INUM0, WNA, s_wfi); how_long = CAR(args); args = CDR(args); if NULLP(args) port1 = cur_inp; @@ -481,11 +491,11 @@ SCM wait_for_input(args) args = CDR(args); } timeout = num2long(how_long, (char *)ARG1, s_wfi); - ASSERT(timeout >= 0, how_long, ARG1, s_wfi); + ASRTER(timeout >= 0, how_long, ARG1, s_wfi); port = port1; ports = args; while (1) { - ASSERT(NIMP(port) && OPINPORTP(port) && (BUF0 & SCM_PORTFLAGS(port)), + ASRTER(NIMP(port) && OPINPORTP(port) && (BUF0 & SCM_PORTFLAGS(port)), port, pos, s_wfi); if (CRDYP(port) || feof(STREAM(port))) timeout = 0; if (NULLP(ports)) break; @@ -516,7 +526,7 @@ SCM wait_for_input(args) 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); + ASRTER(ret>=0, MAKINUM(ret), "select error", s_wfi); port = port1; ports = args; @@ -538,17 +548,21 @@ SCM wait_for_input(args) 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); +# ifdef _WIN32 + if (fileno(f)==fileno(stdin) && (isatty(fileno(stdin))) && kbhit()) + ans = cons(port, ans); # else - if (fileno(f)==fileno(stdin) && (isatty(fileno(stdin))) && kbhit()) - ans = cons(port, ans); +# ifdef FIONREAD + long remir; + ioctl(fileno(f), FIONREAD, &remir); + if (remir) ans = cons(port, ans); +# else + /* If we get here this is not going to work */ +# endif # endif - if (NULLP(ports)) break; - port = CAR(ports); - ports = CDR(ports); + if (NULLP(ports)) break; + port = CAR(ports); + ports = CDR(ports); } } while (time((timet*)0L) < start); #endif @@ -608,7 +622,7 @@ SCM lflush(port) /* user accessible as force-output */ SCM port; { if UNBNDP(port) port = cur_outp; - else ASSERT(NIMP(port) && OPOUTPORTP(port), port, ARG1, s_flush); + else ASRTER(NIMP(port) && OPOUTPORTP(port), port, ARG1, s_flush); { sizet i = PTOBNUM(port); while ((ptobs[i].fflush)(STREAM(port)) && @@ -622,7 +636,7 @@ SCM lwrite(obj, port) SCM obj, port; { if UNBNDP(port) port = cur_outp; - else ASSERT(NIMP(port) && OPOUTPORTP(port), port, ARG2, s_write); + else ASRTER(NIMP(port) && OPOUTPORTP(port), port, ARG2, s_write); iprin1(obj, port, 1); return UNSPECIFIED; } @@ -630,7 +644,7 @@ SCM display(obj, port) SCM obj, port; { if UNBNDP(port) port = cur_outp; - else ASSERT(NIMP(port) && OPOUTPORTP(port), port, ARG2, s_display); + else ASRTER(NIMP(port) && OPOUTPORTP(port), port, ARG2, s_display); iprin1(obj, port, 0); return UNSPECIFIED; } @@ -638,7 +652,7 @@ SCM newline(port) SCM port; { if UNBNDP(port) port = cur_outp; - else ASSERT(NIMP(port) && OPOUTPORTP(port), port, ARG1, s_newline); + else ASRTER(NIMP(port) && OPOUTPORTP(port), port, ARG1, s_newline); lputc('\n', port); if (port==cur_outp) lfflush(port); return UNSPECIFIED; @@ -647,8 +661,8 @@ SCM write_char(chr, port) SCM chr, port; { if UNBNDP(port) port = cur_outp; - else ASSERT(NIMP(port) && OPOUTPORTP(port), port, ARG2, s_write_char); - ASSERT(ICHRP(chr), chr, ARG1, s_write_char); + else ASRTER(NIMP(port) && OPOUTPORTP(port), port, ARG2, s_write_char); + ASRTER(ICHRP(chr), chr, ARG1, s_write_char); lputc((int)ICHR(chr), port); return UNSPECIFIED; } @@ -656,7 +670,7 @@ SCM scm_freshline(port) SCM port; { if UNBNDP(port) port = cur_outp; - else ASSERT(NIMP(port) && OPOUTPORTP(port), port, ARG1, s_freshline); + else ASRTER(NIMP(port) && OPOUTPORTP(port), port, ARG1, s_freshline); if (INUM0==scm_port_col(port)) return UNSPECIFIED; lputc('\n', port); if (port==cur_outp) lfflush(port); @@ -688,7 +702,7 @@ void lputs(s, port) SCM port; { sizet i = PTOBNUM(port); - ASSERT(s, INUM0, ARG1, "lputs"); + ASRTER(s, INUM0, ARG1, "lputs"); while (EOF==(ptobs[i].fputs)(s, STREAM(port)) && scm_io_error(port, "fputs")) ; @@ -775,7 +789,7 @@ void lungetc(c, port) SCM port; { int i = PTOBNUM(port); -/* ASSERT(!CRDYP(port), port, ARG2, "too many lungetc");*/ +/* ASRTER(!CRDYP(port), port, ARG2, "too many lungetc");*/ if (ptobs[i].ungetc) (ptobs[i].ungetc)(c, port); else { @@ -789,7 +803,7 @@ SCM scm_read_char(port) { int c; if UNBNDP(port) port = cur_inp; - ASSERT(NIMP(port) && OPINPORTP(port), port, ARG1, s_read_char); + ASRTER(NIMP(port) && OPINPORTP(port), port, ARG1, s_read_char); c = lgetc(port); if (EOF==c) return EOF_VAL; return MAKICHR(c); @@ -799,7 +813,7 @@ SCM peek_char(port) { int c; if UNBNDP(port) port = cur_inp; - else ASSERT(NIMP(port) && OPINPORTP(port), port, ARG1, s_peek_char); + else ASRTER(NIMP(port) && OPINPORTP(port), port, ARG1, s_peek_char); c = lgetc(port); if (EOF==c) return EOF_VAL; lungetc(c, port); @@ -832,187 +846,209 @@ static int flush_ws(port) return c; } } -SCM lread(port) + +/* Top-level readers */ +static SCM p_read_numbered, p_read_for_load, p_read; +static char s_read[] = "read"; +static char s_read_for_load[] = "read-for-load"; +static char s_read_numbered[] = "read-numbered"; +SCM scm_read(port) SCM port; { return lread1(port, 0, s_read); } -static SCM lread1(port, nump, what) + +SCM scm_read_for_load(port) + SCM port; +{ + return lread1(port, 4, s_read_for_load); +} + +SCM scm_read_numbered(port) + SCM port; +{ + return lread1(port, 6, s_read_numbered); +} + +static SCM lread1(port, flgs, what) SCM port; - int nump; + int flgs; char *what; { int c; SCM tok_buf; if UNBNDP(port) port = cur_inp; - ASSERT(NIMP(port) && OPINPORTP(port), port, ARG1, what); + ASRTER(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, nump))); + } while (EOF_VAL==(tok_buf = lreadr(tok_buf, port, flgs))); return tok_buf; } -static SCM *loc_readsharp = 0, *loc_readsharpc = 0; -static SCM lreadpr(tok_buf, port, nump) +static SCM *loc_loadsharp = 0, *loc_readsharp = 0, *loc_charsharp = 0; +static SCM lreadpr(tok_buf, port, flgs) SCM tok_buf; SCM port; - int nump; + int flgs; { - int c; - sizet j; - SCM p; - if (2==nump) - return lread_rec(tok_buf, port); -tryagain: - c = flush_ws(port); - switch (c) { - case EOF: return EOF_VAL; + int c; + sizet j; + SCM p; + if (2==(3&flgs)) return lread_rec(tok_buf, port); + tryagain: + c = flush_ws(port); + switch (c) { + case EOF: return EOF_VAL; #ifdef BRACKETS_AS_PARENS - case '[': + case '[': #endif - case '(': - return lreadparen(tok_buf, port, nump, s_list); + case '(': return lreadparen(tok_buf, port, flgs, s_list); #ifdef BRACKETS_AS_PARENS - case ']': + case ']': #endif - case ')': return UNDEFINED; /* goto tryagain; */ - 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; - else { - lungetc(c, port); - p = i_unquote; - } - return cons2(p, lreadr(tok_buf, port, nump), EOL); - case '#': - c = lgetc(port); - switch (c) { + case ')': return UNDEFINED; /* goto tryagain; */ + case '\'': return cons2(i_quote, + lreadr(tok_buf, port, flgs), EOL); + case '`': return cons2(i_quasiquote, + lreadr(tok_buf, port, flgs), EOL); + case ',': + c = lgetc(port); + if ('@'==c) p = i_uq_splicing; + else { + lungetc(c, port); + p = i_unquote; + } + return cons2(p, lreadr(tok_buf, port, flgs), EOL); + case '#': + c = lgetc(port); + switch (c) { #ifdef BRACKETS_AS_PARENS - case '[': + case '[': #endif - case '(': - 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; - case 'b': case 'B': case 'o': case 'O': - case 'd': case 'D': case 'x': case 'X': - case 'i': case 'I': case 'e': case 'E': - lungetc(c, port); - c = '#'; - goto num; - case '*': - j = read_token(c, tok_buf, port); - p = istr2bve(CHARS(tok_buf)+1, (long)(j-1)); - if (NFALSEP(p)) return p; - else goto unkshrp; - case '\\': - c = lgetc(port); - j = read_token(c, tok_buf, port); - if (j==1) return MAKICHR(c); - if (c >= '0' && c < '8') { - p = istr2int(CHARS(tok_buf), (long)j, 8); - if (NFALSEP(p)) return MAKICHR(INUM(p)); - } - for (c = 0;c= 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; - return makfromstr(CHARS(tok_buf), j); - case DIGITS: - case '.': case '-': case '+': -num: - j = read_token(c, tok_buf, port); - p = istring2number(CHARS(tok_buf), (long)j, 10L); - if NFALSEP(p) return p; - if (c=='#') { - if ((j==2) && (lgetc(port)=='(')) { - lungetc('(', port); - c = CHARS(tok_buf)[1]; - goto callshrp; - } - wta(UNDEFINED, s_unknown_sharp, CHARS(tok_buf)); - } - goto tok; - default: - j = read_token(c, tok_buf, port); -tok: - p = intern(CHARS(tok_buf), j); - return CAR(p); + case '(': + p = lreadparen(tok_buf, port, flgs, s_vector); + return NULLP(p) ? nullvect : vector(p); + case 't': case 'T': return BOOL_T; + case 'f': case 'F': return BOOL_F; + case 'b': case 'B': case 'o': case 'O': + case 'd': case 'D': case 'x': case 'X': + case 'i': case 'I': case 'e': case 'E': + lungetc(c, port); + c = '#'; + goto num; + case '*': + j = read_token(c, tok_buf, port); + p = istr2bve(CHARS(tok_buf)+1, (long)(j-1)); + if (NFALSEP(p)) return p; + else goto unkshrp; + case '\\': + c = lgetc(port); + j = read_token(c, tok_buf, port); + if (j==1) return MAKICHR(c); + for (c = 0;c= 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; + return makfromstr(CHARS(tok_buf), j); + case DIGITS: + case '.': case '-': case '+': + num: + j = read_token(c, tok_buf, port); + p = istring2number(CHARS(tok_buf), (long)j, 10L); + if NFALSEP(p) return p; + if (c=='#') { + if ((j==2) && (lgetc(port)=='(')) { + lungetc('(', port); + c = CHARS(tok_buf)[1]; + goto callshrp; + } + wta(UNDEFINED, s_unknown_sharp, CHARS(tok_buf)); + } + goto tok; + default: + j = read_token(c, tok_buf, port); + tok: + p = intern(CHARS(tok_buf), j); + return CAR(p); + } } -static SCM lreadr(tok_buf, port, nump) +static SCM lreadr(tok_buf, port, flgs) SCM tok_buf; SCM port; - int nump; + int flgs; { - SCM ans = lreadpr(tok_buf, port, nump); + SCM ans = lreadpr(tok_buf, port, flgs); switch (ans) { case UNDEFINED: scm_warn("unexpected \")\"", "", port); - return lreadpr(tok_buf, port, nump); + return lreadpr(tok_buf, port, flgs); } return ans; } @@ -1026,8 +1062,8 @@ static SCM lread_rec(tok_buf, port) default: lungetc(c, port); line = scm_port_line(port); - form = lreadpr(tok_buf, port, 1); - if (NFALSEP(line) && NIMP(form) && + form = lreadpr(tok_buf, port, 5); + if (NFALSEP(line) && NIMP(form) && (CONSP(form) || VECTORP(form))) { return cons(SCM_MAKE_LINUM(INUM(line)), form); } @@ -1076,26 +1112,37 @@ static sizet read_token(ic, tok_buf, port) _Pragma("opt"); /* # pragma _CRI opt */ #endif -static SCM lreadparen(tok_buf, port, nump, name) +/* flgs was originally an argument to determine whether a read was */ +/* top-level or recursve. It has been overloaded to determine also */ +/* what to do in the case of a recursive read. */ +/* It distinguishes four states: */ +/* 0 - not adding line-numbers - never changes. Uses READ:SHARP */ +/* 4 - not adding line-numbers - never changes. Uses LOAD:SHARP */ +/* 5 - top level read when adding line-numbers. Uses LOAD:SHARP */ +/* 6 - recursive read when adding line-numbers. Uses LOAD:SHARP */ + +static SCM lreadparen(tok_buf, port, flgs, name) SCM tok_buf; SCM port; - int nump; + int flgs; char *name; { - SCM lst, fst, tmp = lreadpr(tok_buf, port, nump ? 2 : 0); + SCM lst, fst, + tmp = lreadpr(tok_buf, port, (4&flgs) | ((3&flgs) ? 2 : 0)); if (UNDEFINED==tmp) return EOL; if (i_dot==tmp) { - fst = lreadr(tok_buf, port, nump ? 1 : 0); + fst = lreadr(tok_buf, port, (4&flgs) | ((3&flgs) ? 1 : 0)); closeit: 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, nump ? 2 : 0))) { + while (UNDEFINED != + (tmp = lreadpr(tok_buf, port, (4&flgs) | ((3&flgs) ? 2 : 0)))) { if (EOF_VAL==tmp) wta(lst, s_eofin, s_list); if (i_dot==tmp) { - CDR(lst) = lreadr(tok_buf, port, nump ? 1 : 0); + CDR(lst) = lreadr(tok_buf, port, (4&flgs) | ((3&flgs) ? 1 : 0)); goto closeit; } lst = (CDR(lst) = cons(tmp, EOL)); @@ -1111,7 +1158,7 @@ SCM swapcar(pair, value) SCM pair, value; { SCM ret; - ASSERT(NIMP(pair) && CONSP(pair), pair, ARG1, s_swapcar); + ASRTER(NIMP(pair) && CONSP(pair), pair, ARG1, s_swapcar); DEFER_INTS; ret = CAR(pair); CAR(pair) = value; @@ -1124,7 +1171,7 @@ long tc16_arbiter; SCM tryarb(arb) SCM arb; { - ASSERT((TYP16(arb)==tc16_arbiter), arb, ARG1, s_tryarb); + ASRTER((TYP16(arb)==tc16_arbiter), arb, ARG1, s_tryarb); DEFER_INTS; if (CAR(arb) & (1L<<16)) arb = BOOL_F; @@ -1138,7 +1185,7 @@ SCM tryarb(arb) SCM relarb(arb) SCM arb; { - ASSERT((TYP16(arb)==tc16_arbiter), arb, ARG1, s_relarb); + ASRTER((TYP16(arb)==tc16_arbiter), arb, ARG1, s_relarb); if (!(CAR(arb) & (1L<<16))) return BOOL_F; CAR(arb) = tc16_arbiter; return BOOL_T; @@ -1226,7 +1273,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 @@ -1254,40 +1301,6 @@ int handle_it(i) } return errmsgs[i-WNA].parent_err; } -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, 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, env, EOL); - } - return BOOL_T; -} SCM exitval = MAKINUM(EXIT_FAILURE); /* INUM return value */ extern char s_unexec[]; @@ -1423,7 +1436,7 @@ SCM scm_port_line(port) SCM port; { sizet lnum; - ASSERT(NIMP(port) && PORTP(port), port, ARG1, s_port_line); + ASRTER(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)) { @@ -1441,7 +1454,7 @@ SCM scm_port_col(port) SCM port; { long col; - ASSERT(NIMP(port) && PORTP(port), port, ARG1, s_port_col); + ASRTER(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)) { @@ -1461,7 +1474,7 @@ SCM scm_port_filename(port) SCM port; { SCM x; - ASSERT(NIMP(port) && PORTP(port), port, ARG1, s_port_filename); + ASRTER(NIMP(port) && PORTP(port), port, ARG1, s_port_filename); x = SCM_PORTDATA(port); if (NIMP(x) && STRINGP(x)) return SCM_PORTDATA(port); @@ -1672,7 +1685,7 @@ SCM repl() scm_env_work = scm_ecache_index - scm_ecache_len; scm_egcs = scm_clo_moved = scm_stk_moved = 0; lmallocated = mallocated; - x = lread(cur_inp); + x = scm_read_for_load(cur_inp); rt = INUM(my_time()); scm_gcs = 0; gc_time_taken = 0; @@ -1732,7 +1745,7 @@ SCM abrt() char s_restart[] = "restart"; SCM restart() { - /* ASSERT(!dumped, UNDEFINED, "dumped can't", s_restart); */ + /* ASRTER(!dumped, UNDEFINED, "dumped can't", s_restart); */ longjump(CONT(rootcont)->jmpbuf, COOKIE(-3)); } @@ -1741,8 +1754,8 @@ char s_unexec[] = "unexec"; SCM scm_unexec(newpath) SCM newpath; { - ASSERT(NIMP(newpath) && STRINGP(newpath), newpath, ARG1, s_unexec); - ASSERT(execpath, UNSPECIFIED, s_no_execpath, s_unexec); + ASRTER(NIMP(newpath) && STRINGP(newpath), newpath, ARG1, s_unexec); + ASRTER(execpath, UNSPECIFIED, s_no_execpath, s_unexec); *loc_errobj = newpath; longjump(CONT(rootcont)->jmpbuf, COOKIE(-4)); } @@ -1796,20 +1809,10 @@ void ints_warn(str1, str2, fname, linum) } #endif -#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); + ASRTER(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); @@ -1828,7 +1831,7 @@ SCM tryload(filename, reader) #endif while(1) { if (UNBNDP(reader)) - form = lread(port); + form = scm_read_for_load(port); else form = scm_cvapply(reader, 1L, &port); if (EOF_VAL==form) break; @@ -1840,6 +1843,40 @@ SCM tryload(filename, reader) } return BOOL_T; } +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 = scm_read(str); + 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 + ASRTER(NIMP(str) && (STRINGP(str) || SYMBOLP(str)), str, ARG1, + s_load_string); + str = mkstrport(INUM0, str, OPN | RDNG, s_load_string); + while(1) { + SCM form = scm_read_for_load(str); + if (EOF_VAL==form) break; + SIDEVAL(form, env, EOL); + } + return BOOL_T; +} void scm_line_msg(file, linum, port) SCM file, linum, port; @@ -1925,7 +1962,7 @@ static char s_perror[] = "perror"; SCM lperror(arg) SCM arg; { - ASSERT(NIMP(arg) && STRINGP(arg), arg, ARG1, s_perror); + ASRTER(NIMP(arg) && STRINGP(arg), arg, ARG1, s_perror); err_head(CHARS(arg)); return UNSPECIFIED; } @@ -1984,9 +2021,10 @@ static void def_err_response() err_pos = 0; if (!UNBNDP(obj)) if (reset_safeport(sys_safep, 55, cur_errp)) - if (0==setjmp(SAFEP_JMPBUF(sys_safep))) + if (0==setjmp(SAFEP_JMPBUF(sys_safep))) { 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)) @@ -2079,7 +2117,7 @@ SCM set_inp(port) SCM port; { SCM oinp; - ASSERT(NIMP(port) && INPORTP(port), port, ARG1, s_cur_inp); + ASRTER(NIMP(port) && INPORTP(port), port, ARG1, s_cur_inp); DEFER_INTS; oinp = cur_inp; cur_inp = port; @@ -2090,7 +2128,7 @@ SCM set_outp(port) SCM port; { SCM ooutp; - ASSERT(NIMP(port) && OUTPORTP(port), port, ARG1, s_cur_outp); + ASRTER(NIMP(port) && OUTPORTP(port), port, ARG1, s_cur_outp); DEFER_INTS; ooutp = cur_outp; cur_outp = port; @@ -2101,7 +2139,7 @@ SCM set_errp(port) SCM port; { SCM oerrp; - ASSERT(NIMP(port) && OUTPORTP(port), port, ARG1, s_cur_errp); + ASRTER(NIMP(port) && OUTPORTP(port), port, ARG1, s_cur_errp); DEFER_INTS; oerrp = cur_errp; cur_errp = port; @@ -2112,7 +2150,7 @@ static char s_isatty[] = "isatty?"; SCM l_isatty(port) SCM port; { - ASSERT(NIMP(port) && OPPORTP(port), port, ARG1, s_isatty); + ASRTER(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; } @@ -2144,7 +2182,6 @@ static iproc subr1s[] = { {0, 0}}; static iproc subr1os[] = { - {s_read, lread}, {s_read_char, scm_read_char}, {s_peek_char, peek_char}, {s_newline, newline}, @@ -2177,21 +2214,24 @@ void init_repl( iverbose ) i_repl = CAR(sysintern("repl", UNDEFINED)); loc_errobj = &CDR(sysintern("errobj", UNDEFINED)); loc_loadpath = &CDR(sysintern("*load-pathname*", BOOL_F)); + loc_loadsharp = &CDR(sysintern("load:sharp", UNDEFINED)); loc_readsharp = &CDR(sysintern("read:sharp", UNDEFINED)); - loc_readsharpc = &CDR(sysintern("read:sharp-char", UNDEFINED)); + loc_charsharp = &CDR(sysintern("char:sharp", 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); + p_read_numbered = + make_subr(s_read_numbered, tc7_subr_1, scm_read_numbered); + p_read_for_load = + make_subr(s_read_for_load, tc7_subr_1, scm_read_for_load); + p_read = + make_subr(s_read, tc7_subr_1o, scm_read); i_eval_string = CAR(sysintern(s_eval_string, UNDEFINED)); i_load_string = CAR(sysintern(s_load_string, UNDEFINED)); #ifdef CAN_DUMP @@ -2214,6 +2254,7 @@ void init_repl( iverbose ) } void final_repl() { + i_eval_string = i_load_string = 0; loc_errobj = (SCM *)&tmp_errobj; loc_loadpath = (SCM *)&tmp_loadpath; loadports = EOL; -- cgit v1.2.3