From 5ca6e8e6a4e5c022a6fb5d28f30219c22c99eda8 Mon Sep 17 00:00:00 2001 From: Bryan Newbold Date: Mon, 20 Feb 2017 00:05:23 -0800 Subject: Import Upstream version 4e6 --- repl.c | 1649 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 1649 insertions(+) create mode 100644 repl.c (limited to 'repl.c') diff --git a/repl.c b/repl.c new file mode 100644 index 0000000..48ac94a --- /dev/null +++ b/repl.c @@ -0,0 +1,1649 @@ +/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995 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. + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of GUILE. + * + * The exception is that, if you link the GUILE 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. + * + * 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 + * code from other Free Software Foundation releases into a copy of + * GUILE, 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 + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. + */ + +/* "repl.c" error, read-eval-print loop, read, write and load code. + Author: Aubrey Jaffer */ + +#include "scm.h" +#include "setjump.h" +void igc P((char *what, STACKITEM *stackbase)); + +#ifdef ARM_ULIB +# include +int set_erase() +{ + struct termio tin; + + ioctl(0, TCGETA, &tin); + tin.c_cc[VERASE] = '\010'; + + ioctl(0, TCSETA,&tin); + return(0); +} +#endif + +unsigned char upcase[CHAR_CODE_LIMIT]; +unsigned char downcase[CHAR_CODE_LIMIT]; +unsigned char lowers[] = "abcdefghijklmnopqrstuvwxyz"; +unsigned char uppers[] = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; +extern int verbose; +void init_tables() +{ + int i; + for(i = 0;i", "#", "()", "#" + }; + +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_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 sizet read_token P((int ic, SCM tok_buf, SCM port)); + +void intprint(n, radix, port) + long n; + int radix; + SCM port; +{ + char num_buf[INTBUFLEN]; + lfwrite(num_buf, (sizet)sizeof(char), iint2str(n, radix, num_buf), port); +} + +void ipruk(hdr, ptr, port) + char *hdr; + SCM ptr; + SCM port; +{ + lputs("#', port); +} + +void iprlist(hdr, exp, tlr, port, writing) + char *hdr, tlr; + SCM exp; + SCM port; + int writing; +{ + lputs(hdr, port); + /* CHECK_INTS; */ + iprin1(CAR(exp), port, writing); + exp = CDR(exp); + for(;NIMP(exp);exp = CDR(exp)) { + if NECONSP(exp) break; + lputc(' ', port); + /* CHECK_INTS; */ + iprin1(CAR(exp), port, writing); + } + if NNULLP(exp) { + lputs(" . ", port); + iprin1(exp, port, writing); + } + lputc(tlr, port); +} +void iprin1(exp, port, writing) + SCM exp; + SCM port; +int writing; +{ + register long i; +taloop: + switch (7 & (int)exp) { + case 2: + case 6: + intprint(INUM(exp), 10, port); + break; + case 4: + if ICHRP(exp) { + i = ICHR(exp); + if (writing) lputs("#\\", port); + if (!writing) lputc((int)i, port); + else if ((i <= ' ') && charnames[i]) lputs(charnames[i], port); +#ifndef EBCDIC + else if (i=='\177') + lputs(charnames[(sizeof charnames/sizeof(char *))-1], port); +#endif /* ndef EBCDIC */ + else if (i > '\177') + intprint(i, 8, port); + else lputc((int)i, port); + } + else if (IFLAGP(exp) && (ISYMNUM(exp)<(sizeof isymnames/sizeof(char *)))) + lputs(ISYMCHARS(exp), port); + else if ILOCP(exp) { + lputs("#@", port); + intprint((long)IFRAME(exp), 10, port); + lputc(ICDRP(exp)?'-':'+', port); + intprint((long)IDIST(exp), 10, port); + } + else goto idef; + break; + case 1: /* gloc */ + lputs("#@", port); + exp = CAR(exp-1); + goto taloop; + default: + idef: + ipruk("immediate", exp, port); + break; + case 0: + switch TYP7(exp) { + 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); + break; + case tc7_string: + if (writing) { + lputc('\"', port); + for(i = 0;i', port); + break; +#ifdef CCLO + case tc7_cclo: + lputs("#', port); + break; +#endif + case tc7_contin: + lputs("#', port); + break; + case tc7_port: + i = PTOBNUM(exp); + if (i +# include +static int input_waiting(f) + FILE *f; +{ + if (feof(f)) return 1; + if (fileno(f)==fileno(stdin) && (isatty(fileno(stdin)))) return kbhit(); + return -1; +} +# endif +#else +# ifdef _DCC +# include +# else +# ifndef AMIGA +# ifndef vms +# ifdef MWC +# include +# else +# ifndef THINK_C +# ifndef ARM_ULIB +# include +# endif +# endif +# endif +# endif +# endif +# endif + +# ifdef HAVE_SELECT +# ifdef HAVE_SYS_TIME_H +# include +# endif +# endif + +static int input_waiting(f) + FILE *f; +{ +# ifdef HAVE_SELECT + fd_set ifds; + struct timeval tv; + + FD_ZERO(&ifds); + FD_SET(fileno(f), &ifds); + tv.tv_sec = 0; + tv.tv_usec = 0; + select((fileno(f) + 1), &ifds, (fd_set *) NULL, (fd_set *) NULL, &tv); + return FD_ISSET(fileno(f), &ifds); +# else +# ifdef FIONREAD + long remir; + if (feof(f)) return 1; + ioctl(fileno(f), FIONREAD, &remir); + return remir; +# else + return -1; +# endif +# endif +} +#endif +/* perhaps should undefine MSDOS from __IBMC__ here */ +#ifndef GO32 +static char s_char_readyp[]="char-ready?"; +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; + return input_waiting(STREAM(port)) ? BOOL_T : BOOL_F; +} +#endif + +SCM eof_objectp(x) + SCM x; +{ + return (EOF_VAL==x) ? BOOL_T : BOOL_F; +} + +void lfflush(port) /* internal SCM call */ + SCM port; +{ + sizet i = PTOBNUM(port); + (ptobs[i].fflush)(STREAM(port)); +} +static char s_flush[] = "force-output"; +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); + { + sizet i = PTOBNUM(port); + SYSCALL((ptobs[i].fflush)(STREAM(port));); + return UNSPECIFIED; + } +} + +SCM lwrite(obj, port) + SCM 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) + SCM 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) + SCM 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); + return UNSPECIFIED; +} +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); + lputc((int)ICHR(chr), port); +#ifdef HAVE_PIPE +# ifdef EPIPE + if (EPIPE==errno) close_port(port); +# endif +#endif + return UNSPECIFIED; +} + +FILE *trans = 0; +SCM trans_on(fil) + SCM fil; +{ + transcript = open_file(fil, makfromstr("w", (sizet)sizeof(char))); + if FALSEP(transcript) trans = 0; + else trans = STREAM(transcript); + return UNSPECIFIED; +} +SCM trans_off() +{ + if (!FALSEP(transcript)) close_port(transcript); + transcript = BOOL_F; + trans = 0; + return UNSPECIFIED; +} + +void lputc(c, port) + int c; + SCM port; +{ + sizet i = PTOBNUM(port); + SYSCALL((ptobs[i].fputc)(c, STREAM(port));); + if (trans && (port==def_outp || port==cur_errp)) + SYSCALL(fputc(c, trans);); +} +void lputs(s, port) + char *s; + SCM port; +{ + sizet i = PTOBNUM(port); + SYSCALL((ptobs[i].fputs)(s, STREAM(port));); + if (trans && (port==def_outp || port==cur_errp)) + SYSCALL(fputs(s, trans);); +} +int lfwrite(ptr, size, nitems, port) + char *ptr; + sizet size; + sizet nitems; + SCM port; +{ + int ret; + sizet 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);); + return ret; +} + +int lgetc(port) + SCM 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 */ + return c; + } + 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);); + return c; +} +void lungetc(c, port) + int c; + SCM port; +{ +/* ASSERT(!CRDYP(port), port, ARG2, "too many lungetc");*/ + CUNGET(c, port); +} + +SCM scm_read_char(port) + SCM port; +{ + int c; + if UNBNDP(port) port = cur_inp; + else ASSERT(NIMP(port) && OPINPORTP(port), port, ARG1, s_read_char); + c = lgetc(port); + if (EOF==c) return EOF_VAL; + return MAKICHR(c); +} +SCM peek_char(port) + SCM port; +{ + int c; + if UNBNDP(port) port = cur_inp; + else ASSERT(NIMP(port) && OPINPORTP(port), port, ARG1, s_peek_char); + c = lgetc(port); + if (EOF==c) return EOF_VAL; + lungetc(c, port); + return MAKICHR(c); +} + +char *grow_tok_buf(tok_buf) + SCM tok_buf; +{ + sizet len = LENGTH(tok_buf); + len += len / 2; + resizuve(tok_buf, (SCM)MAKINUM(len)); + return CHARS(tok_buf); +} + +static int flush_ws(port, eoferr) + SCM port; +char *eoferr; +{ + register int c; + while(1) switch (c = lgetc(port)) { + case EOF: +goteof: + if (eoferr) wta(UNDEFINED, s_eofin, eoferr); + return c; + case ';': +lp: + switch (c = lgetc(port)) { + case EOF: + goto goteof; + default: + goto lp; + case LINE_INCREMENTORS: + break; + } + case LINE_INCREMENTORS: + if (port==loadport) linum++; + case WHITE_SPACES: + break; + default: + return c; + } +} +SCM lread(port) + SCM port; +{ + int c; + SCM tok_buf; + if UNBNDP(port) port = cur_inp; + else ASSERT(NIMP(port) && OPINPORTP(port), port, ARG1, s_read); + do { + c = flush_ws(port, (char *)NULL); + if (EOF==c) return EOF_VAL; + lungetc(c, port); + tok_buf = makstr(30L); + } while (EOF_VAL==(tok_buf = lreadr(tok_buf, port))); + return tok_buf; +} +static SCM lreadr(tok_buf, port) + SCM tok_buf; +SCM port; +{ + int c; + sizet j; + SCM p; +tryagain: + c = flush_ws(port, s_read); + switch (c) { +/* case EOF: return EOF_VAL;*/ +#ifdef BRACKETS_AS_PARENS + case '[': +#endif + case '(': return lreadparen(tok_buf, port, s_list); +#ifdef BRACKETS_AS_PARENS + case ']': +#endif + case ')': warn("unexpected \")\"", ""); + goto tryagain; + case '\'': return cons2(i_quote, lreadr(tok_buf, port), EOL); + case '`': return cons2(i_quasiquote, lreadr(tok_buf, port), 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), EOL); + case '#': + c = lgetc(port); + switch (c) { +#ifdef BRACKETS_AS_PARENS + case '[': +#endif + case '(': + p = lreadparen(tok_buf, port, 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); + 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; + } + 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); + } +} + +#ifdef _UNICOS +_Pragma("noopt"); /* # pragma _CRI noopt */ +#endif +static sizet read_token(ic, tok_buf, port) + int ic; + SCM tok_buf; + SCM port; +{ + register sizet j = 1; + register int c = ic; + register char *p = CHARS(tok_buf); + p[0] = downcase[c]; + while(1) { + if (j+1 >= LENGTH(tok_buf)) p = grow_tok_buf(tok_buf); + switch (c = lgetc(port)) { +#ifdef BRACKETS_AS_PARENS + case '[': case ']': +#endif + case '(': case ')': case '\"': case ';': + case ',': case '`': case '#': + case WHITE_SPACES: + case LINE_INCREMENTORS: + lungetc(c, port); + case EOF: + p[j] = 0; + return j; + default: + p[j++] = downcase[c]; + } + } +} +#ifdef _UNICOS +_Pragma("opt"); /* # pragma _CRI opt */ +#endif + +static SCM lreadparen(tok_buf, port, name) + SCM tok_buf; + SCM port; + char *name; +{ + SCM tmp, tl, ans; + int c = flush_ws(port, name); + if (')'==c +#ifdef BRACKETS_AS_PARENS + || ']'==c +#endif + ) return EOL; + lungetc(c, port); + if (i_dot==(tmp = lreadr(tok_buf, port))) { + ans = lreadr(tok_buf, port); + closeit: + if (')' != (c = flush_ws(port, name)) +#ifdef BRACKETS_AS_PARENS + && ']' != c +#endif + ) + wta(UNDEFINED, "missing close paren", ""); + return ans; + } + ans = tl = cons(tmp, EOL); + while (')' != (c = flush_ws(port, name)) +#ifdef BRACKETS_AS_PARENS + && ']' != c +#endif + ) { + lungetc(c, port); + if (i_dot==(tmp = lreadr(tok_buf, port))) { + CDR(tl) = lreadr(tok_buf, port); + goto closeit; + } + tl = (CDR(tl) = cons(tmp, EOL)); + } + return ans; +} + +/* These procedures implement synchronization primitives. Processors + with an atomic test-and-set instruction can use it here (and not + DEFER_INTS). */ +char s_tryarb[] = "try-arbiter"; +char s_relarb[] = "release-arbiter"; +long tc16_arbiter; +SCM tryarb(arb) + SCM arb; +{ + ASSERT((TYP16(arb)==tc16_arbiter), arb, ARG1, s_tryarb); + DEFER_INTS; + if (CAR(arb) & (1L<<16)) + arb = BOOL_F; + else { + CAR(arb) = tc16_arbiter | (1L<<16); + arb = BOOL_T; + } + ALLOW_INTS; + return arb; +} +SCM relarb(arb) + SCM arb; +{ + ASSERT((TYP16(arb)==tc16_arbiter), arb, ARG1, s_relarb); + if (!(CAR(arb) & (1L<<16))) return BOOL_F; + CAR(arb) = tc16_arbiter; + return BOOL_T; +} +SCM makarb(name) + SCM name; +{ + register SCM z; + NEWCELL(z); + CDR(z) = name; + CAR(z) = tc16_arbiter; + return z; +} +static int prinarb(exp, port, writing) + SCM exp; SCM port; int writing; +{ + lputs("#', port); + return !0; +} + +static char s_tryload[] = "try-load"; +#define s_load (&s_tryload[4]) + +struct errdesc {char *msg;char *s_response;short parent_err;}; +struct errdesc errmsgs[] = { + {"Wrong number of args", 0, 0}, + {"numerical overflow", 0, FPE_SIGNAL}, + {"Argument out of range", 0, FPE_SIGNAL}, + {"Could not allocate", "out-of-storage", 0}, + {"EXIT", "end-of-program", -1}, + {"hang up", "hang-up", EXIT}, + {"user interrupt", "user-interrupt", 0}, + {"arithmetic error", "arithmetic-error", 0}, + {"bus error", 0, 0}, + {"segment violation", 0, 0}, + {"alarm", "alarm-interrupt", 0} +}; + +int errjmp_bad = 1, ints_disabled = 1, sig_deferred = 0, alrm_deferred; +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; +SCM loadport = UNDEFINED; +long linum = 1; +int verbose = 1; +long cells_allocated = 0, lcells_allocated = 0, + mallocated = 0, lmallocated = 0, + rt = 0, gc_rt, gc_time_taken; +long gc_cells_collected, gc_malloc_collected, gc_ports_collected; +long gc_syms_collected; +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) return -1; /* sends it to def_err_response */ + if (name) { + NEWCELL(proc); /* discard possibly-used cell */ + proc = CDR(intern(name, (sizet)strlen(name))); + if NIMP(proc) { + apply(proc, EOL, EOL); + return i; + } + } + return errmsgs[i-WNA].parent_err; +} +static char s_eval_string[] = "eval-string"; +static char s_load_string[] = "load-string"; +SCM scm_eval_string(str) + SCM str; +{ + str = mkstrport(INUM0, str, OPN | RDNG, s_eval_string); + str = lread(str); + return EVAL(str, (SCM)EOL); +} +SCM scm_load_string(str) + SCM str; +{ + 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); + } + return BOOL_T; +} + +SCM exitval; /* INUM with return value */ +extern char s_unexec[]; +SCM repl_driver(initpath) + char *initpath; +{ +#ifdef _UNICOS + int i; +#else + long i; +#endif + CONT(rootcont)->stkbse = (STACKITEM *)&i; + i = setjmp(CONT(rootcont)->jmpbuf); +#ifndef SHORT_INT + if (i) i = UNCOOK(i); +#endif + /* printf("repl_driver 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); + } + if ((i = errmsgs[i-WNA].parent_err)) goto drloop; + def_err_response(); + goto reset_toplvl; + } + case 0: + exitval = MAKINUM(EXIT_SUCCESS); + errjmp_bad = 0; + errno = 0; + alrm_deferred = 0; + sig_deferred = 0; + ints_disabled = 0; + if (dumped) { + lcells_allocated = cells_allocated; + lmallocated = mallocated; + rt = INUM(my_time()); + gc_time_taken = 0; + } + else if (scm_ldfile(initpath)) /* load Scheme init files */ + wta(*loc_errobj, "Could not open file", s_load); + scm_evstr("(boot-tail)"); /* initialization tail-call */ + case -2: /* abrt */ + reset_toplvl: + errjmp_bad = 0; + alrm_deferred = 0; + sig_deferred = 0; + ints_disabled = 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 (verbose > 1) { + lputs("; Aborting load (closing): ", cur_errp); + display(*loc_loadpath, cur_errp); + newline(cur_errp); + } + close_port(loadport); /* close loading file. */ + } +#endif + *loc_loadpath = BOOL_F; + loadport = UNDEFINED; + repl(); + err_pos = (char *)EXIT; + i = EXIT; + goto drloop; /* encountered EOF on stdin */ + case -1: /* quit */ + return exitval; + case -3: /* restart. */ + return 0; +#ifdef CAN_DUMP + case -4: /* dump */ + igc(s_unexec, (STACKITEM *)0); + dumped = 1; + unexec(CHARS(*loc_errobj), execpath, 0, 0, 0); + goto reset_toplvl; +#endif + } +} + +SCM line_num() +{ + return MAKINUM(linum); +} +SCM prog_args() +{ + return progargs; +} + +extern char s_heap[]; +extern sizet hplim_ind; +extern CELLPTR *hplims; +void growth_mon(obj, size, units) + char *obj; + long size; + char *units; +{ + if (verbose>2) + { + lputs("; grew ", cur_errp); + lputs(obj, cur_errp); + lputs(" to ", cur_errp); + intprint(size, 10, cur_errp); + lputc(' ', cur_errp); + lputs(units, cur_errp); + if ((verbose>4) && (obj==s_heap)) heap_report(); + lputs("\n", cur_errp); + } +} + +void gc_start(what) + char *what; +{ + if (verbose>3 && FPORTP(cur_errp)) { + ALLOW_INTS; + lputs(";GC(", cur_errp); + lputs(what, cur_errp); + lputs(")", cur_errp); + lfflush(cur_errp); + DEFER_INTS; + } + gc_rt = INUM(my_time()); + gc_cells_collected = 0; + gc_malloc_collected = 0; + gc_ports_collected = 0; + gc_syms_collected = 0; +} +void gc_end() +{ + gc_rt = INUM(my_time()) - gc_rt; + gc_time_taken = gc_time_taken + gc_rt; + if (verbose>3) { + ALLOW_INTS; + if (!FPORTP(cur_errp)) lputs(";GC ", cur_errp); + intprint(time_in_msec(gc_rt), 10, cur_errp); + lputs(" cpu mSec, ", cur_errp); + intprint(gc_cells_collected, 10, cur_errp); + lputs(" cells, ", cur_errp); + intprint(gc_malloc_collected, 10, cur_errp); + lputs(" malloc, ", cur_errp); + intprint(gc_syms_collected, 10, cur_errp); + lputs(" syms, ", cur_errp); + intprint(gc_ports_collected, 10, cur_errp); + lputs(" ports collected\n", cur_errp); + lfflush(cur_errp); + DEFER_INTS; + } +} +void repl_report() +{ + if (verbose>1) { + lfflush(cur_outp); + lputs(";Evaluation took ", cur_errp); + intprint(time_in_msec(INUM(my_time())-rt), 10, cur_errp); + lputs(" mSec (", cur_errp); + intprint(time_in_msec(gc_time_taken), 10, cur_errp); + lputs(" in gc) ", cur_errp); + intprint(cells_allocated - lcells_allocated, 10, cur_errp); + lputs(" cells work, ", cur_errp); + intprint(mallocated - lmallocated, 10, cur_errp); + lputs(" bytes other\n", cur_errp); + lfflush(cur_errp); + } +} +SCM lroom(args) + SCM args; +{ + intprint(cells_allocated, 10, cur_errp); + lputs(" out of ", cur_errp); + intprint(heap_size, 10, cur_errp); + lputs(" cells in use, ", cur_errp); + intprint(mallocated, 10, cur_errp); + lputs(" bytes allocated (of ", cur_errp); + intprint(mtrigger, 10, cur_errp); + lputs(")\n", cur_errp); + if NIMP(args) { + heap_report(); + lputs("\n", cur_errp); + stack_report(); + } + return UNSPECIFIED; +} +void heap_report() +{ + sizet i = 0; + lputs("; heap segments:", cur_errp); + while(i2) { + lputs(";Totals: ", cur_errp); + intprint(time_in_msec(INUM(my_time())), 10, cur_errp); + lputs(" mSec my time, ", cur_errp); + intprint(time_in_msec(INUM(your_time())), 10, cur_errp); + lputs(" mSec your time\n", cur_errp); + } +} + +SCM prolixity(arg) + SCM arg; +{ + int old = verbose; + if (!UNBNDP(arg)) { + if FALSEP(arg) verbose = 1; + else verbose = INUM(arg); + } + return MAKINUM(old); +} + +void repl() +{ + SCM x; + 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; + lmallocated = mallocated; + x = lread(cur_inp); + rt = INUM(my_time()); + gc_time_taken = 0; + if (EOF_VAL==x) break; + if (!CRDYP(cur_inp)) /* assure newline read (and transcripted) */ + lungetc(lgetc(cur_inp), cur_inp); +#ifdef __TURBOC__ + if ('\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); + } +} +SCM quit(n) + SCM n; +{ + if (UNBNDP(n) || BOOL_T==n) n = MAKINUM(EXIT_SUCCESS); + else if INUMP(n) exitval = n; + else exitval = MAKINUM(EXIT_FAILURE); + if (errjmp_bad) exit(INUM(exitval)); + dowinds(EOL, ilength(dynwinds)); + longjmp(CONT(rootcont)->jmpbuf, COOKIE(-1)); +} +SCM abrt() +{ + if (errjmp_bad) exit(INUM(exitval)); + dowinds(EOL, ilength(dynwinds)); +#ifdef CAUTIOUS + stacktrace = EOL; +#endif + longjmp(CONT(rootcont)->jmpbuf, COOKIE(-2)); +} +char s_restart[] = "restart"; +SCM restart() +{ + /* ASSERT(!dumped, UNDEFINED, "dumped can't", s_restart); */ + dowinds(EOL, ilength(dynwinds)); +#ifdef CAUTIOUS + stacktrace = EOL; +#endif + longjmp(CONT(rootcont)->jmpbuf, COOKIE(-3)); +} + +#ifdef CAN_DUMP +char s_unexec[] = "unexec"; +SCM scm_unexec(newpath) + SCM newpath; +{ + ASSERT(NIMP(newpath) && STRINGP(newpath), newpath, ARG1, s_unexec); + *loc_errobj = newpath; +# ifdef CAUTIOUS + stacktrace = EOL; +# endif + longjmp(CONT(rootcont)->jmpbuf, COOKIE(-4)); +} +#endif + +char s_execpath[] = "execpath"; +SCM scm_execpath(newpath) + SCM newpath; +{ + SCM retval = execpath ? makfrom0str(execpath) : BOOL_F; + if (UNBNDP(newpath)) + return retval; + if (FALSEP(newpath)) { + if (execpath) free(execpath); + execpath = 0; + return retval; + } + ASSERT(NIMP(newpath) && STRINGP(newpath), newpath, ARG1, s_execpath); + if (execpath) free(execpath); + execpath = scm_cat_path(0L, CHARS(newpath), 0L); + return retval; +} + +void han_sig() +{ + sig_deferred = 0; + if (INT_SIGNAL != handle_it(INT_SIGNAL)) + wta(UNDEFINED, (char *)INT_SIGNAL, ""); +} +void han_alrm() +{ + alrm_deferred = 0; + if (ALRM_SIGNAL != handle_it(ALRM_SIGNAL)) + wta(UNDEFINED, (char *)ALRM_SIGNAL, ""); +} + +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); + } + } + return BOOL_T; +} +#ifdef CAUTIOUS +void scm_print_stack(stk) + SCM stk; +{ + switch (ilength(stk)) { + case -1: + lputs("\n; circular stacktrace!", cur_errp); + return; + case -2: + lputs("\n; stacktrace not a list?", cur_errp); + iprin1(stk, cur_errp, 1); + return; + default: + while NNULLP(stk) { + SCM ste = CAR(stk); + lputc('\n', cur_errp); + iprin1(ste, cur_errp, 1); + stk = CDR(stk); + } + } +} +SCM scm_stack_trace() +{ + if (0==ilength(stacktrace)) return BOOL_F; + scm_print_stack(stacktrace); + return BOOL_T; +} +#endif + +static void err_head(str) + char *str; +{ + 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); + lputs(", line ", cur_errp); + intprint((long)linum, 10, cur_errp); + lputs(": ", cur_errp); + } + lfflush(cur_errp); + errno = oerrno; + if (cur_errp==def_errp) { + if (errno>0) perror(str); + fflush(stderr); + return; + } +} +void warn(str1, str2) + char *str1, *str2; +{ + err_head("WARNING"); + lputs("WARNING: ", cur_errp); + lputs(str1, cur_errp); + lputs(str2, cur_errp); + lputc('\n', cur_errp); + lfflush(cur_errp); +} + +SCM lerrno(arg) + SCM arg; +{ + int old = errno; + if (!UNBNDP(arg)) { + if FALSEP(arg) errno = 0; + else errno = INUM(arg); + } + return MAKINUM(old); +} +static char s_perror[] = "perror"; +SCM lperror(arg) + SCM arg; +{ + ASSERT(NIMP(arg) && STRINGP(arg), arg, ARG1, s_perror); + err_head(CHARS(arg)); + return UNSPECIFIED; +} +static void def_err_response() +{ + SCM obj = *loc_errobj; +#ifdef CAUTIOUS + SCM stk = stacktrace; +#endif + DEFER_INTS; + err_head("ERROR"); + lputs("ERROR: ", cur_errp); + if (err_s_subr && *err_s_subr) { + lputs(err_s_subr, cur_errp); + lputs(": ", cur_errp); + } + 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) { + lputs("Wrong type in arg", cur_errp); + lputc(err_pos ? '0'+(short)err_pos : ' ', cur_errp); + } +#else + if ((~0x1fL) & (long)err_pos) lputs(err_pos, cur_errp); + else if (WNA>(long)err_pos) { + lputs("Wrong type in arg", cur_errp); + lputc(err_pos ? '0'+(int)err_pos : ' ', 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 + if NNULLP(stk) scm_print_stack(stk); +#endif + 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 NULLP(err_env) lputs("\n; in top level environment.", cur_errp); + else { + SCM env = err_env; + 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); + } + } + getout: + lputc('\n', cur_errp); + lfflush(cur_errp); + err_exp = err_env = UNDEFINED; + if (errjmp_bad) { + iprin1(obj, cur_errp, 1); + lputs("\nFATAL ERROR DURING CRITICAL CODE SECTION\n", cur_errp); +#ifdef vms + exit(EXIT_FAILURE); +#else + exit(errno? (long)errno : EXIT_FAILURE); +#endif + } + errno = 0; + ALLOW_INTS; +} +void everr(exp, env, arg, pos, s_subr) + SCM exp, env, arg; + char *pos, *s_subr; +{ + err_exp = exp; + err_env = env; + *loc_errobj = arg; + err_pos = pos; + err_s_subr = s_subr; +#ifndef CAUTIOUS + if (((~0x1fL) & (long)pos) || (WNA>(long)pos) + || NIMP(dynwinds) || errjmp_bad) +#endif + { + def_err_response(); + dowinds(EOL, ilength(dynwinds)); + abrt(); + } +#ifndef CAUTIOUS + /* We don't have to clear stacktrace because CAUTIOUS never gets here */ + /* We don't have to dowinds() because dynwinds is EOL */ + longjmp(CONT(rootcont)->jmpbuf, COOKIE((int)pos)); + /* will do error processing at stack base */ +#endif +} +void wta(arg, pos, s_subr) + SCM arg; +char *pos, *s_subr; +{ + everr(UNDEFINED, EOL, arg, pos, s_subr); +} +SCM cur_input_port() +{ + return cur_inp; +} +SCM cur_output_port() +{ + return cur_outp; +} +SCM cur_error_port() +{ + return cur_errp; +} +char s_cur_inp[] = "set-current-input-port"; +char s_cur_outp[] = "set-current-output-port"; +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); + cur_inp = port; + return oinp; +} +SCM set_outp(port) + SCM port; +{ + SCM ooutp = cur_outp; + ASSERT(NIMP(port) && OPOUTPORTP(port), port, ARG1, s_cur_outp); + cur_outp = port; + return ooutp; +} +SCM set_errp(port) + SCM port; +{ + SCM oerrp = cur_errp; + ASSERT(NIMP(port) && OPOUTPORTP(port), port, ARG1, s_cur_errp); + cur_errp = port; + return oerrp; +} + +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}, + {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}, + {"transcript-on", trans_on}, + {s_tryload, tryload}, + {s_load_string, scm_load_string}, + {s_eval_string, scm_eval_string}, + {s_perror, lperror}, + {"make-arbiter", makarb}, + {s_tryarb, tryarb}, + {s_relarb, relarb}, + {0, 0}}; + +static iproc subr1os[] = { + {s_read, lread}, + {s_read_char, scm_read_char}, + {s_peek_char, peek_char}, + {s_newline, newline}, + {s_flush, lflush}, +#ifndef GO32 + {s_char_readyp, char_readyp}, +#endif + {"quit", quit}, + {"verbose", prolixity}, + {"errno", lerrno}, + {s_execpath, scm_execpath}, + {0, 0}}; + +static iproc subr2os[] = { + {s_write, lwrite}, + {s_display, display}, + {s_write_char, write_char}, +#ifdef CAN_DUMP + {s_unexec, scm_unexec}, +#endif + {0, 0}}; + +static smobfuns arbsmob = {markcdr, free0, prinarb}; +char s_ccl[] = "char-code-limit"; + +void init_repl( iverbose ) + int 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; + verbose = iverbose; + init_iprocs(subr0s, tc7_subr_0); + init_iprocs(subr1os, tc7_subr_1o); + init_iprocs(subr1s, tc7_subr_1); + init_iprocs(subr2os, tc7_subr_2o); + make_subr("room", tc7_lsubr, lroom); +#ifndef GO32 + add_feature(s_char_readyp); +#endif +#ifdef CAN_DUMP + if (!execpath) execpath = dld_find_executable(CHARS(CAR(progargs))); + add_feature("dump"); + scm_ldstr("\ +(define (dump file . thunk)\n\ + (cond ((null? thunk) (set! *interactive* #f) (set! *argv* #f))\n\ + ((not (car thunk)) (set! *argv* #f))\n\ + ((boolean? (car thunk)))\n\ + (else (set! boot-tail (car thunk))))\n\ + (set! restart exec-self)\n\ + (unexec file))\n\ +"); +#endif +#ifdef ARM_ULIB + set_erase(); +#endif + tc16_arbiter = newsmob(&arbsmob); +} +void final_repl() +{ + loc_errobj = (SCM *)&tmp_errobj; + loc_loadpath = (SCM *)&tmp_loadpath; + loadport = UNDEFINED; + transcript = BOOL_F; + trans = 0; + linum = 1; +} -- cgit v1.2.3