/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1997, 1998 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)); void unexec P((char *new_name, char *a_name, unsigned data_start, unsigned bss_start, unsigned entry_address)); #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"; void init_tables() { int i; for(i = 0;i", /* user visible ISYMS */ /* other keywords */ /* Flags */ "#f", "#t", "#", "#", "()", "#" }; 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 = GCCDR(exp); /* CDR(exp); */ for(;NIMP(exp);exp = GCCDR(exp) /* CDR(exp)*/) { if (!scm_cell_p(~1L & exp)) break; 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 */ if (!scm_cell_p(exp-1)) { ipruk("gloc", exp, port); break; } lputs("#@", port); exp = CAR(exp-1); goto taloop; default: idef: ipruk("immediate", exp, port); break; case 0: if (!scm_cell_p(exp)) { ipruk("heap", exp, port); break; } 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; case tc7_specfun: #ifdef CCLO if (tc16_cclo==TYP16(exp)) { lputs("#', port); break; } #endif lputs("#', port); break; 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 macintosh # 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; int ret; FD_ZERO(&ifds); FD_SET(fileno(f), &ifds); tv.tv_sec = 0; 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); 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 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 = try_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); ASSERT(s, INUM0, ARG1, "lputs"); 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) SCM port; { register int c; while(1) switch (c = lgetc(port)) { case ';': lp: switch (c = lgetc(port)) { default: goto lp; case EOF: return c; case LINE_INCREMENTORS: break; } case LINE_INCREMENTORS: if (port==loadport) linum++; case WHITE_SPACES: break; case EOF: 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); 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 lreadpr(tok_buf, port) SCM tok_buf; SCM port; { int c; sizet j; SCM p; tryagain: c = flush_ws(port); 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 ')': return UNDEFINED; /* goto tryagain; */ case '\'': return cons2(i_quote, lreadr(tok_buf, port), EOL); case '`': return cons2(i_quasiquote, lreadr(tok_buf, port), EOL); case ',': 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); } } static SCM lreadr(tok_buf, port) SCM tok_buf; SCM port; { SCM ans = lreadpr(tok_buf, port); switch (ans) { case UNDEFINED: warn("unexpected \")\"", ""); return lreadpr(tok_buf, port); } return ans; } #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 lst, fst, tmp = lreadpr(tok_buf, port); if (UNDEFINED==tmp) return EOL; if (i_dot==tmp) { fst = lreadr(tok_buf, port); closeit: tmp = lreadpr(tok_buf, port); if (UNDEFINED != tmp) wta(UNDEFINED, "missing close paren", ""); return fst; } fst = lst = cons(tmp, EOL); while (UNDEFINED != (tmp = lreadpr(tok_buf, port))) { if (EOF_VAL==tmp) wta(lst, s_eofin, s_list); if (i_dot==tmp) { CDR(lst) = lreadr(tok_buf, port); goto closeit; } lst = (CDR(lst) = cons(tmp, EOL)); } return fst; } /* 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}, {"Thrashing", "thrashing", 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}, {"profile interrupt", "profile-interrupt", 0}, }; void (* deferred_proc) P((void)) = 0; int errjmp_bad = 1, ints_disabled = 1; unsigned long SIG_deferred = 0; SCM err_exp, err_env; char *err_pos, *err_s_subr; cell tmp_errobj = {(SCM)UNDEFINED, (SCM)EOL}; cell tmp_loadpath = {(SCM)BOOL_F, (SCM)EOL}; SCM *loc_errobj = (SCM *)&tmp_errobj; SCM *loc_loadpath = (SCM *)&tmp_loadpath; SCM loadport = UNDEFINED; long linum = 1; int scm_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; long scm_env_work = 0, scm_gcs = 0, scm_egcs = 0, scm_stk_moved = 0, scm_clo_moved = 0, scm_egc_rt; 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) wta(UNDEFINED, (char *)i, ""); /* sends it to def_err_response */ if (name) { SCM n[2]; int j; for (j=0; j<2; j++) { NEWCELL(n[j]); /* discard 2 possibly-used cells */ } CDR(n[1]) = EOL; proc = CDR(intern(name, (sizet)strlen(name))); 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 scm_egc(); #endif estk = scm_estk; estk_ptr = scm_estk_ptr; env = scm_env; env_tmp = scm_env_tmp; scm_estk = BOOL_F; scm_estk_reset(); ALLOW_INTS; apply(proc, EOL, EOL); DEFER_INTS; scm_estk = estk; scm_estk_ptr = estk_ptr; scm_env = env; scm_env_tmp = env_tmp; scm_fill_freelist(); ALLOW_INTS; 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 = MAKINUM(EXIT_FAILURE); /* INUM 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 = setjump(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; lflush(sys_errp); errno = 0; SIG_deferred = 0; deferred_proc = 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 boot_tail = scm_evstr("boot-tail"); /* initialization tail-call */ apply(boot_tail, (dumped ? BOOL_T : BOOL_F), listofnull); } case -2: /* abrt */ reset_toplvl: ints_disabled = 1; errjmp_bad = 0; lflush(sys_errp); SIG_deferred = 0; deferred_proc = 0; scm_estk_reset(); /* 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 (scm_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; ints_disabled = 0; 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 */ DEFER_INTS; scm_estk_reset(); scm_egc(); igc(s_unexec, (STACKITEM *)0); ALLOW_INTS; dumped = 1; # ifdef linux /* 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; #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, grewp) char *obj; long size; char *units; int grewp; { if (verbose>2) { lputs((grewp ? "; grew " : "; shrank "), sys_errp); lputs(obj, sys_errp); lputs(" to ", sys_errp); intprint(size, -10, sys_errp); lputc(' ', sys_errp); lputs(units, sys_errp); if ((verbose>4) && (obj==s_heap)) heap_report(); lputs("\n", sys_errp); } } void gc_start(what) char *what; { if (verbose>3 && FPORTP(cur_errp)) { lputs(";GC(", sys_errp); lputs(what, sys_errp); lputs(")", sys_errp); } scm_gcs++; 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) { if (!FPORTP(cur_errp)) lputs(";GC ", sys_errp); intprint(time_in_msec(gc_rt), -10, sys_errp); lputs(" cpu mSec, ", sys_errp); intprint(gc_cells_collected, -10, sys_errp); lputs(" cells, ", sys_errp); intprint(gc_malloc_collected, -10, sys_errp); lputs(" malloc, ", sys_errp); intprint(gc_syms_collected, -10, sys_errp); lputs(" syms, ", sys_errp); intprint(gc_ports_collected, -10, sys_errp); lputs(" ports collected\n", sys_errp); } } void scm_egc_start() { scm_egc_rt = INUM(my_time()); scm_egcs++; } void scm_egc_end() { scm_egc_rt = INUM(my_time()) - scm_egc_rt; gc_time_taken = gc_time_taken + scm_egc_rt; } 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); scm_env_work += scm_ecache_len - scm_ecache_index; intprint(scm_env_work, -10, cur_errp); lputs(" env, ", cur_errp); intprint(mallocated - lmallocated, -10, cur_errp); lputs(" bytes other\n", cur_errp); if (verbose>2) { lputc(';', cur_errp); intprint(scm_gcs, -10, cur_errp); lputs( " gc, ", cur_errp); intprint(scm_egcs, -10, cur_errp); lputs( " ecache gc, ", cur_errp); intprint(scm_clo_moved, -10, cur_errp); lputs(" env migrated from closures, ", cur_errp); intprint(scm_stk_moved, -10, cur_errp); lputs(" from stack\n", cur_errp); } lfflush(cur_errp); } } #ifndef LACK_SBRK extern long scm_init_brk, scm_dumped_brk; void scm_brk_report() { 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) { lputs(", dumped = 0x", cur_errp); intprint(scm_dumped_brk, -16, cur_errp); } lputs(", current = 0x", cur_errp); intprint(scm_curbrk, -16, cur_errp); lputs("; ", cur_errp); intprint(dif1, 10, cur_errp); if (dumped) { lputs(dif2<0 ? " - " : " + ", cur_errp); intprint(dif2<0 ? -dif2 : dif2, 10, cur_errp); } lputs(" kb\n", cur_errp); } #endif #ifdef NUM_HP extern long num_hp_total; #endif SCM lroom(opt) SCM opt; { intprint(cells_allocated, -10, cur_errp); lputs(" out of ", cur_errp); intprint(heap_cells, -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 (!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(); #endif scm_ecache_report(); heap_report(); lputc('\n', cur_errp); stack_report(); } return UNSPECIFIED; } void heap_report() { sizet i = 0; lputs(";; heap segments:", sys_errp); while(i < hplim_ind) { { long seg_cells = CELL_DN(hplims[i+1]) - CELL_UP(hplims[i]); lputs("\n; 0x", sys_errp); intprint((long)hplims[i++], -16, sys_errp); lputs(" - 0x", sys_errp); intprint((long)hplims[i++], -16, sys_errp); lputs("; ", sys_errp); intprint(seg_cells, 10, sys_errp); lputs(" cells; ", sys_errp); intprint(seg_cells / (1024 / sizeof(CELLPTR)), 10, sys_errp); lputs(" kb", sys_errp); }} } void scm_ecache_report() { 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_ecache_len - scm_ecache_index, 10, cur_errp); lputs(" out of ", cur_errp); intprint(scm_ecache_len, 10, cur_errp); lputs(" env cells in use.\n", cur_errp); } void exit_report() { if (verbose>2) { 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) scm_verbose = 1; else scm_verbose = INUM(arg); } return MAKINUM(old); } void 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); } #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); #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); 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); *loc_errobj = newpath; longjump(CONT(rootcont)->jmpbuf, COOKIE(-4)); } #endif #ifdef CAREFUL_INTS ints_infot *ints_info = 0; static void ints_viol_iprin(num) long num; { char num_buf[INTBUFLEN]; sizet i = iint2str(num, 10, num_buf); num_buf[i] = 0; fputs(num_buf, stderr); } void ints_viol(info, sense) ints_infot *info; int sense; { fputs(info->fname, stderr); fputc(':', stderr); ints_viol_iprin(info->linum); fputs(": ints already ", stderr); fputs(sense ? "dis" : "en", stderr); fputs("abled (", stderr); ints_viol_iprin((long)ints_disabled); fputs(")\n", stderr); if (ints_info) { fputs(ints_info->fname, stderr); fputc(':', stderr); ints_viol_iprin(ints_info->linum); fputs(": last change\n", stderr); } ints_info = info; } void ints_warn(str1, str2, fname, linum) char *str1, *str2, *fname; int linum; { fputs(fname, stderr); fputc(':', stderr); ints_viol_iprin(linum); fputs(" :uprotected call to ", stderr); fputs(str1, stderr); if (str2) { fputs(" (", stderr); fputs(str2, stderr); fputc(')', stderr); } fputc('\n', stderr); } #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 form, port; port = open_file(filename, makfromstr("r", (sizet)sizeof(char))); if FALSEP(port) return port; *loc_loadpath = filename; loadport = port; linum = 1; while(1) { form = lread(port); if (EOF_VAL==form) break; SIDEVAL(form, EOL); } close_port(port); linum = olninum; loadport = oloadport; *loc_loadpath = oloadpath; } return BOOL_T; } #endif #ifdef CAUTIOUS static void trace1(estk, n) SCM estk; int n; { 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); } 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; 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; } do { trace1(scm_estk, n); } while (--n > 0); 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); if (str2) { 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; 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 scm_stack_trace(); #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; if (NIMP(env) && tc16_env==CAR(env)) env = CDR(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) { lputs("\nerrobj: ", cur_errp); iprin1(obj, cur_errp, 1); newline(cur_errp); lroom(BOOL_T); 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; 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)); /* will do error processing at stack base */ } 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 char s_isatty[] = "isatty?"; SCM l_isatty(port) SCM port; { ASSERT(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; } 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}, {s_isatty, l_isatty}, {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}, {"find-init-file", scm_find_impl}, {"room", lroom}, {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; 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 #ifdef CAN_DUMP 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 (lambda (t) ((car thunk))))))\n\ (set! restart exec-self)\n\ (require #f)\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; }