diff options
Diffstat (limited to 'repl.c')
-rw-r--r-- | repl.c | 230 |
1 files changed, 137 insertions, 93 deletions
@@ -1,4 +1,4 @@ -/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc. +/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1997 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 @@ -45,6 +45,8 @@ #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 <termio.h> @@ -119,6 +121,8 @@ char *isymnames[] = { "#@and", "#@begin", "#@case", "#@cond", "#@do", "#@if", "#@lambda", "#@let", "#@let*", "#@letrec", "#@or", "#@quote", "#@set!", "#@define", "#@apply", "#@call-with-current-continuation", + "#@farloc-car", "#@farloc-cdr", "#@delay", "#@quasiquote", + "#@unquote", "#@unquote-splicing", "#@else", "#@=>", /* user visible ISYMS */ /* other keywords */ /* Flags */ @@ -152,7 +156,7 @@ void ipruk(hdr, ptr, port) { lputs("#<unknown-", port); lputs(hdr, port); - if CELLP(ptr) { + if (scm_cell_p(ptr)) { lputs(" (0x", port); intprint(CAR(ptr), 16, port); lputs(" . 0x", port); @@ -175,6 +179,7 @@ void iprlist(hdr, exp, tlr, port, writing) iprin1(CAR(exp), port, writing); exp = CDR(exp); for(;NIMP(exp);exp = CDR(exp)) { + if (!scm_cell_p(~1L & exp)) break; if NECONSP(exp) break; lputc(' ', port); /* CHECK_INTS; */ @@ -223,6 +228,10 @@ taloop: 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; @@ -231,6 +240,10 @@ taloop: 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: @@ -245,7 +258,7 @@ taloop: if (writing) { lputc('\"', port); for(i = 0;i<LENGTH(exp);++i) switch (CHARS(exp)[i]) { - case '"': + case '\"': case '\\': lputc('\\', port); default: @@ -583,33 +596,22 @@ char *grow_tok_buf(tok_buf) return CHARS(tok_buf); } -static int flush_ws(port, eoferr) +static int flush_ws(port) 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; - } +{ + 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; @@ -619,24 +621,24 @@ SCM lread(port) if UNBNDP(port) port = cur_inp; else ASSERT(NIMP(port) && OPINPORTP(port), port, ARG1, s_read); do { - c = flush_ws(port, (char *)NULL); + 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 lreadr(tok_buf, port) +static SCM lreadpr(tok_buf, port) SCM tok_buf; -SCM port; + SCM port; { int c; sizet j; SCM p; tryagain: - c = flush_ws(port, s_read); + c = flush_ws(port); switch (c) { -/* case EOF: return EOF_VAL;*/ + case EOF: return EOF_VAL; #ifdef BRACKETS_AS_PARENS case '[': #endif @@ -644,8 +646,7 @@ tryagain: #ifdef BRACKETS_AS_PARENS case ']': #endif - case ')': warn("unexpected \")\"", ""); - goto tryagain; + 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 ',': @@ -765,6 +766,18 @@ tok: 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 */ @@ -785,7 +798,8 @@ static sizet read_token(ic, tok_buf, port) case '[': case ']': #endif case '(': case ')': case '\"': case ';': - case ',': case '`': case '#': + case ',': case '`': + /* case '#': */ case WHITE_SPACES: case LINE_INCREMENTORS: lungetc(c, port); @@ -806,39 +820,25 @@ static SCM lreadparen(tok_buf, port, name) 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); + SCM lst, fst, tmp = lreadpr(tok_buf, port); + if (UNDEFINED==tmp) return EOL; + if (i_dot==tmp) { + fst = lreadr(tok_buf, port); closeit: - if (')' != (c = flush_ws(port, name)) -#ifdef BRACKETS_AS_PARENS - && ']' != c -#endif - ) - wta(UNDEFINED, "missing close paren", ""); - return ans; + tmp = lreadpr(tok_buf, port); + if (UNDEFINED != tmp) wta(UNDEFINED, "missing close paren", ""); + return fst; } - 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); + 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; } - tl = (CDR(tl) = cons(tmp, EOL)); + lst = (CDR(lst) = cons(tmp, EOL)); } - return ans; + return fst; } /* These procedures implement synchronization primitives. Processors @@ -962,7 +962,7 @@ SCM scm_load_string(str) return BOOL_T; } -SCM exitval; /* INUM with return value */ +SCM exitval = MAKINUM(EXIT_FAILURE); /* INUM return value */ extern char s_unexec[]; SCM repl_driver(initpath) char *initpath; @@ -973,7 +973,7 @@ SCM repl_driver(initpath) long i; #endif CONT(rootcont)->stkbse = (STACKITEM *)&i; - i = setjmp(CONT(rootcont)->jmpbuf); + i = setjump(CONT(rootcont)->jmpbuf); #ifndef SHORT_INT if (i) i = UNCOOK(i); #endif @@ -1218,20 +1218,20 @@ SCM quit(n) SCM n; { if (UNBNDP(n) || BOOL_T==n) n = MAKINUM(EXIT_SUCCESS); - else if INUMP(n) exitval = n; + 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)); + longjump(CONT(rootcont)->jmpbuf, COOKIE(-1)); } SCM abrt() { - if (errjmp_bad) exit(INUM(exitval)); + if (errjmp_bad) exit(EXIT_FAILURE); dowinds(EOL, ilength(dynwinds)); #ifdef CAUTIOUS stacktrace = EOL; #endif - longjmp(CONT(rootcont)->jmpbuf, COOKIE(-2)); + longjump(CONT(rootcont)->jmpbuf, COOKIE(-2)); } char s_restart[] = "restart"; SCM restart() @@ -1241,24 +1241,11 @@ SCM restart() #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)); + longjump(CONT(rootcont)->jmpbuf, COOKIE(-3)); } -#endif -char s_execpath[] = "execpath"; +char s_no_ep[] = "no execpath"; +#define s_execpath (s_no_ep+3) SCM scm_execpath(newpath) SCM newpath; { @@ -1272,10 +1259,36 @@ SCM scm_execpath(newpath) } ASSERT(NIMP(newpath) && STRINGP(newpath), newpath, ARG1, s_execpath); if (execpath) free(execpath); - execpath = scm_cat_path(0L, CHARS(newpath), 0L); + if ((execpath = (char *)malloc((sizet)(LENGTH(newpath) + 1)))) + 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; +# ifdef CAUTIOUS + stacktrace = EOL; +# endif + longjump(CONT(rootcont)->jmpbuf, COOKIE(-4)); +} +#endif + +#ifdef CAREFUL_INTS +void ints_viol(sense) + int sense; +{ + fputs(";ints already ", stderr); + fputs(sense ? "en" : "dis", stderr); + fputs("abled\n", stderr); +} +#endif + void han_sig() { sig_deferred = 0; @@ -1289,6 +1302,7 @@ void han_alrm() wta(UNDEFINED, (char *)ALRM_SIGNAL, ""); } +#ifdef TAIL_RECURSIVE_LOAD SCM tryload(filename) SCM filename; { @@ -1317,8 +1331,36 @@ SCM tryload(filename) 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 void scm_print_stack(stk) SCM stk; @@ -1375,9 +1417,11 @@ void warn(str1, str2) err_head("WARNING"); lputs("WARNING: ", cur_errp); lputs(str1, cur_errp); - lputs(str2, cur_errp); - lputc('\n', cur_errp); - lfflush(cur_errp); + if (str2) { + lputs(str2, cur_errp); + lputc('\n', cur_errp); + lfflush(cur_errp); + } } SCM lerrno(arg) @@ -1497,7 +1541,7 @@ void everr(exp, env, arg, pos, s_subr) #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)); + longjump(CONT(rootcont)->jmpbuf, COOKIE((int)pos)); /* will do error processing at stack base */ #endif } @@ -1621,7 +1665,6 @@ void init_repl( iverbose ) 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\ @@ -1630,6 +1673,7 @@ void init_repl( iverbose ) ((boolean? (car thunk)))\n\ (else (set! boot-tail (car thunk))))\n\ (set! restart exec-self)\n\ + (require #f)\n\ (unexec file))\n\ "); #endif |