summaryrefslogtreecommitdiffstats
path: root/repl.c
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:25 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:25 -0800
commit3278b75942bdbe706f7a0fba87729bb1e935b68b (patch)
treedcad4048dfc0b38367047426b2b14501bf5ff257 /repl.c
parentdb04688faa20f3576257c0fe41752ec435beab9a (diff)
downloadscm-3278b75942bdbe706f7a0fba87729bb1e935b68b.tar.gz
scm-3278b75942bdbe706f7a0fba87729bb1e935b68b.zip
Import Upstream version 5d2upstream/5d2
Diffstat (limited to 'repl.c')
-rw-r--r--repl.c856
1 files changed, 533 insertions, 323 deletions
diff --git a/repl.c b/repl.c
index a60d7e8..20be8b1 100644
--- a/repl.c
+++ b/repl.c
@@ -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;
}