Import Upstream version 5e1upstream/5e1

1 files changed, 53 insertions, 23 deletions

diff --git a/repl.c b/repl.c
index 07b357c..a3204dc 100644
--- a/repl.c
+++ b/repl.c
@@ -316,7 +316,22 @@ taloop:
 	break;
       }
     case tcs_symbols:
-      lfwrite(CHARS(exp), (sizet)sizeof(char), (sizet)LENGTH(exp), port);
+      if (writing) {		/* slashified symbol */
+	for(i = 0;i<LENGTH(exp);++i) switch (CHARS(exp)[i]) {
+	case '\\': case '\"': case '\'': case '(': case ')': case '#':
+	case 'A': case 'B': case 'C': case 'D': case 'E':
+	case 'F': case 'G': case 'H': case 'I': case 'J':
+	case 'K': case 'L': case 'M': case 'N': case 'O':
+	case 'P': case 'Q': case 'R': case 'S': case 'T':
+	case 'U': case 'V': case 'W': case 'X': case 'Y': case 'Z':
+	  lputc('\\', port);
+	default:
+	  lputc(CHARS(exp)[i], port);
+	}
+	break;
+      }
+      else
+	lfwrite(CHARS(exp), (sizet)sizeof(char), (sizet)LENGTH(exp), port);
       break;
     case tc7_vector:
       lputs("#(", port);
@@ -945,7 +960,10 @@ static SCM lreadpr(tok_buf, port, flgs)
       else goto unkshrp;
     case '\\':
       c = lgetc(port);
-      j = read_token(c, tok_buf, port);
+      if ('\\'==c) {
+	CHARS(tok_buf)[0] = c;
+	j = 1;
+      } else j = read_token(c, tok_buf, port);
       if (j==1) return MAKICHR(c);
       for (c = 0;c<sizeof charnames/sizeof(char *);c++)
 	if (charnames[c]
@@ -1087,7 +1105,7 @@ static sizet read_token(ic, tok_buf, port)
 	register sizet j = 1;
 	register int c = ic;
 	register char *p = CHARS(tok_buf);
-	p[0] = downcase[c];
+	p[0] = '\\'==c ? lgetc(port) : downcase[c];
 	while(1) {
 		if (j+1 >= LENGTH(tok_buf)) p = grow_tok_buf(tok_buf);
 		switch (c = lgetc(port)) {
@@ -1103,6 +1121,9 @@ static sizet read_token(ic, tok_buf, port)
 		case EOF:
 			p[j] = 0;
 			return j;
+		case '\\':	/* slashified symbol */
+			p[j++] = lgetc(port);
+			break;
 		default:
 			p[j++] = downcase[c];
 		}
@@ -1260,20 +1281,25 @@ int handle_it(i)
   char *name = errmsgs[i-WNA].s_response;
   if (errjmp_bad || errjmp_recursive)
     wta(UNDEFINED, (char *)i, ""); /* sends it to def_err_response */
+  /* NEWCELL does not defer interrupts; so be careful to maintain the
+     freelist integrity. */
   if (name) {
-    SCM n[2];
     int j;
+    SCM n[2];	   /* GC-protect discarded cells (possibly being used
+		      by interrupted code). */
     DEFER_INTS;
-    for (j=0; j<2; j++) {
-      NEWCELL(n[j]);		/* discard 2 possibly-used cells */
-    }
-    CDR(n[1]) = EOL;
+    /* Two cells are discarded because NEWCELL may have been
+       interrupted between computing the right-hand-side of
+          freelist = CDR(freelist)
+       and assigning it to freelist. */
+    for (j=0; j<2; j++) NEWCELL(n[j]); /* discard 2 possibly-used cells */
+    CDR(n[1]) = EOL;		/* lose pointer to freelist */
     ALLOW_INTS;
+    /* discarding was necessary here because intern() may do NEWCELL */
     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. */
-
+    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
@@ -1299,6 +1325,10 @@ int handle_it(i)
       return i;
     }
   }
+  /* Ensure that freelist is not empty when returning from interrupt */
+  DEFER_INTS;
+  scm_fill_freelist();
+  ALLOW_INTS;
   return errmsgs[i-WNA].parent_err;
 }
 
@@ -1314,13 +1344,12 @@ SCM scm_top_level(initpath, toplvl_fun)
 #else
   long i;
 #endif
+  if (!toplvl_fun) toplvl_fun = repl;
   CONT(rootcont)->stkbse = (STACKITEM *)&i;
   i = setjump(CONT(rootcont)->jmpbuf);
 #ifndef SHORT_INT
   if (i) i = UNCOOK(i);
 #endif
-  if (!toplvl_fun) toplvl_fun = repl;
-  /* printf("scm_top_level got %d\n", i); */
  drloop:
   switch ((int)i) {
   default:
@@ -1914,16 +1943,17 @@ static void err_head(str)
   int oerrno = errno;
   exitval = MAKINUM(EXIT_FAILURE);
   if (NIMP(cur_outp) && OPOUTPORTP(cur_outp)) lfflush(cur_outp);
-  for (lps = loadports; NIMP(lps); lps = CDR(lps)) {
-    lputs(lps==loadports ? "\n;While loading " : "\n  ;loaded from ",
-	  cur_errp);
-    iprin1(scm_port_filename(CAR(lps)), cur_errp, 1);
-    lputs(", line ", cur_errp);
-    iprin1(scm_port_line(CAR(lps)), cur_errp, 1);
-    lputs(": ", cur_errp);
+  lps = IMP(loadports) ? loadports : CDR(loadports);
+  if (NIMP(lps)) {
+    lputs("\n;In file loaded from ", cur_errp);
+    for (; NIMP(lps); lps = CDR(lps)) {
+      iprin1(scm_port_filename(CAR(lps)), cur_errp, 0);
+      lputs(":", cur_errp);
+      iprin1(scm_port_line(CAR(lps)), cur_errp, 1);
+      lputs(IMP(CDR(lps)) ? ":" : ",\n;       loaded from ", cur_errp);
+    }
   }
-  if (NIMP(loadports) && NIMP(CDR(loadports)))
-    lputs("\n;", cur_errp);
+  lputs("\n;", cur_errp);
   lfflush(cur_errp);
   errno = oerrno;
   /* if (NIMP(cur_errp) && stderr==STREAM(cur_errp)) { ... } */