summaryrefslogtreecommitdiffstats
path: root/repl.c
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:24 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:24 -0800
commit1edcb9b62a1a520eddae8403c19d841c9b18737f (patch)
treebc0a43d9b3905726a76ed6f0528b54275f23d082 /repl.c
parent5ca6e8e6a4e5c022a6fb5d28f30219c22c99eda8 (diff)
downloadscm-1edcb9b62a1a520eddae8403c19d841c9b18737f.tar.gz
scm-1edcb9b62a1a520eddae8403c19d841c9b18737f.zip
Import Upstream version 5b3upstream/5b3
Diffstat (limited to 'repl.c')
-rw-r--r--repl.c230
1 files changed, 137 insertions, 93 deletions
diff --git a/repl.c b/repl.c
index 48ac94a..1593909 100644
--- a/repl.c
+++ b/repl.c
@@ -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