Import Upstream version 5b3upstream/5b3

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