From 87a8061e1c5e182755debe6ff597a77d81084f6f Mon Sep 17 00:00:00 2001
From: ceriel <none@none>
Date: Tue, 6 Nov 1990 12:23:41 +0000
Subject: [PATCH] Many more changes

---
 util/grind/c.c          | 133 ++++++++++-----------
 util/grind/char.ct      |   2 +-
 util/grind/commands.g   |  61 ++++++++--
 util/grind/do_comm.c    | 250 ++++++++++++++++++++++++++++++++++++----
 util/grind/expr.c       |   6 +-
 util/grind/itemlist.cc  |   9 +-
 util/grind/main.c       |   2 +
 util/grind/modula-2.c   |  74 ++++++------
 util/grind/operators.ot |   7 ++
 util/grind/position.h   |   2 +-
 util/grind/print.c      |  32 +++--
 util/grind/run.c        |  14 ++-
 util/grind/tokenname.c  |   3 +
 util/grind/tree.c       | 215 ++++++++++++++++++++--------------
 14 files changed, 570 insertions(+), 240 deletions(-)

diff --git a/util/grind/c.c b/util/grind/c.c
index 3c6370997..bdbc570dd 100644
--- a/util/grind/c.c
+++ b/util/grind/c.c
@@ -70,35 +70,36 @@ static struct langdep c = {
 struct langdep *c_dep = &c;
 
 static int
-printchar(c, esc)
+printchar(f, c, esc)
+  FILE	*f;
   int	c;
 {
   c &= 0377;
   switch(c) {
   case '\n':
-	fputs("\\n", db_out);
+	fputs("\\n", f);
 	break;
   case '\t':
-	fputs("\\t", db_out);
+	fputs("\\t", f);
 	break;
   case '\b':
-	fputs("\\b", db_out);
+	fputs("\\b", f);
 	break;
   case '\r':
-	fputs("\\r", db_out);
+	fputs("\\r", f);
 	break;
   case '\f':
-	fputs("\\f", db_out);
+	fputs("\\f", f);
 	break;
   case '\\':
-	fputs("\\\\", db_out);
+	fputs("\\\\", f);
 	break;
   case '\'':
   case '"':
-	fprintf(db_out, c == esc ? "\\%c" : "%c", c);
+	fprintf(f, c == esc ? "\\%c" : "%c", c);
 	break;
   default:
-  	fprintf(db_out, (c >= 040 && c < 0177) ? "%c" : "\\%03o", c);
+  	fprintf(f, (c >= 040 && c < 0177) ? "%c" : "\\%03o", c);
 	break;
   }
 }
@@ -108,20 +109,21 @@ print_char(c)
   int	c;
 {
   putc('\'', db_out);
-  printchar(c, '\'');
+  printchar(db_out, c, '\'');
   putc('\'', db_out);
 }
 
 static int
-print_string(s, len)
+print_string(f, s, len)
+  FILE	*f;
   char	*s;
   int	len;
 {
   register char	*str = s;
 
-  putc('"', db_out);
-  while (*str && len-- > 0) printchar(*str++, '"');
-  putc('"', db_out);
+  putc('"', f);
+  while (*str && len-- > 0) printchar(f, *str++, '"');
+  putc('"', f);
 }
 
 extern long	int_size;
@@ -463,124 +465,125 @@ get_string(c)
 }
 
 static int
-print_op(p)
+print_op(f, p)
+  FILE		*f;
   p_tree	p;
 {
   switch(p->t_oper) {
   case OP_UNOP:
   	switch(p->t_whichoper) {
 	case E_MIN:
-		fputs("-(", db_out);
-		print_node(p->t_args[0], 0);
-		putc(')', db_out);
+		fputs("-(", f);
+		print_node(f, p->t_args[0], 0);
+		putc(')', f);
 		break;
 	case E_PLUS:
-		fputs("+(", db_out);
-		print_node(p->t_args[0], 0);
-		putc(')', db_out);
+		fputs("+(", f);
+		print_node(f, p->t_args[0], 0);
+		putc(')', f);
 		break;
 	case E_NOT:
-		fputs("!(", db_out);
-		print_node(p->t_args[0], 0);
-		putc(')', db_out);
+		fputs("!(", f);
+		print_node(f, p->t_args[0], 0);
+		putc(')', f);
 		break;
 	case E_DEREF:
-		fputs("*(", db_out);
-		print_node(p->t_args[0], 0);
-		putc(')', db_out);
+		fputs("*(", f);
+		print_node(f, p->t_args[0], 0);
+		putc(')', f);
 		break;
 	case E_BNOT:
-		fputs("~(", db_out);
-		print_node(p->t_args[0], 0);
-		putc(')', db_out);
+		fputs("~(", f);
+		print_node(f, p->t_args[0], 0);
+		putc(')', f);
 		break;
 	case E_ADDR:
-		fputs("&(", db_out);
-		print_node(p->t_args[0], 0);
-		putc(')', db_out);
+		fputs("&(", f);
+		print_node(f, p->t_args[0], 0);
+		putc(')', f);
 		break;
 	}
 	break;
   case OP_BINOP:
 	if (p->t_whichoper == E_ARRAY) {
-		print_node(p->t_args[0], 0);
-		fputs("[", db_out);
-		print_node(p->t_args[1], 0);
-		fputs("]", db_out);
+		print_node(f, p->t_args[0], 0);
+		fputs("[", f);
+		print_node(f, p->t_args[1], 0);
+		fputs("]", f);
 		break;
 	}
 	if (p->t_whichoper == E_DERSELECT) {
-		print_node(p->t_args[0], 0);
-		fputs("->", db_out);
-		print_node(p->t_args[1], 0);
+		print_node(f, p->t_args[0], 0);
+		fputs("->", f);
+		print_node(f, p->t_args[1], 0);
 		break;
 	}
 	if (p->t_whichoper == E_SELECT) {
-		print_node(p->t_args[0], 0);
-		fputs(".", db_out);
-		print_node(p->t_args[1], 0);
+		print_node(f, p->t_args[0], 0);
+		fputs(".", f);
+		print_node(f, p->t_args[1], 0);
 		break;
 	}
-	fputs("(", db_out);
-	print_node(p->t_args[0], 0);
+	fputs("(", f);
+	print_node(f, p->t_args[0], 0);
 	switch(p->t_whichoper) {
 	case E_LSFT:
-		fputs("<<", db_out);
+		fputs("<<", f);
 		break;
 	case E_RSFT:
-		fputs(">>", db_out);
+		fputs(">>", f);
 		break;
 	case E_AND:
-		fputs("&&", db_out);
+		fputs("&&", f);
 		break;
 	case E_BAND:
-		fputs("&", db_out);
+		fputs("&", f);
 		break;
 	case E_OR:
-		fputs("||", db_out);
+		fputs("||", f);
 		break;
 	case E_BOR:
-		fputs("|", db_out);
+		fputs("|", f);
 		break;
 	case E_BXOR:
-		fputs("^", db_out);
+		fputs("^", f);
 		break;
 	case E_ZDIV:
-		fputs("/", db_out);
+		fputs("/", f);
 		break;
 	case E_ZMOD:
-		fputs("%", db_out);
+		fputs("%", f);
 		break;
 	case E_PLUS:
-		fputs("+", db_out);
+		fputs("+", f);
 		break;
 	case E_MIN:
-		fputs("-", db_out);
+		fputs("-", f);
 		break;
 	case E_MUL:
-		fputs("*", db_out);
+		fputs("*", f);
 		break;
 	case E_EQUAL:
-		fputs("==", db_out);
+		fputs("==", f);
 		break;
 	case E_NOTEQUAL:
-		fputs("!=", db_out);
+		fputs("!=", f);
 		break;
 	case E_LTEQUAL:
-		fputs("<=", db_out);
+		fputs("<=", f);
 		break;
 	case E_GTEQUAL:
-		fputs(">=", db_out);
+		fputs(">=", f);
 		break;
 	case E_LT:
-		fputs("<", db_out);
+		fputs("<", f);
 		break;
 	case E_GT:
-		fputs(">", db_out);
+		fputs(">", f);
 		break;
 	}
-	print_node(p->t_args[1], 0);
-	fputs(")", db_out);
+	print_node(f, p->t_args[1], 0);
+	fputs(")", f);
 	break;
   }
 }
diff --git a/util/grind/char.ct b/util/grind/char.ct
index 41882de0c..26c7d829d 100644
--- a/util/grind/char.ct
+++ b/util/grind/char.ct
@@ -12,7 +12,7 @@ STIDF:a-zA-Z_
 STSTR:"'
 STDOT:.
 STNUM:0-9
-STSIMP:-,!<>{}:`?\\
+STSIMP:-+,!<>{}:`?\\
 %T#include "class.h"
 %Tchar tkclass[] = {
 %p
diff --git a/util/grind/commands.g b/util/grind/commands.g
index dd0fffb22..72bac4a67 100644
--- a/util/grind/commands.g
+++ b/util/grind/commands.g
@@ -56,10 +56,11 @@ commands
 					lastcom = 0;
 				}
 				if (errorgiven) {
-					freenode(com);
+					if (com != run_command) freenode(com);
 					com = 0;
 				}
 				else {
+					log(com);
 					eval(com);
 			  		if (repeatable(com)) {
 						lastcom = com;
@@ -72,6 +73,7 @@ commands
 					}
 				}
 			  } else if (lastcom && ! errorgiven) {
+				log(lastcom);
 				eval(lastcom);
 			  }
 			  if (give_prompt) {
@@ -81,7 +83,6 @@ commands
 			  }
 			}
   ]*
-			{ signal_child(SIGKILL); }
 ;
 
 command_line(p_tree *p;)
@@ -111,20 +112,48 @@ command_line(p_tree *p;)
 | WHICH qualified_name(p){ *p = mknode(OP_WHICH, *p); }
 | able_command(p)
 | '!'			{ shellescape();
-			  errorgiven = 1; /* to prevent execution of lastcomm */
+			  *p = mknode(OP_SHELL);
 			}
+| source_command(p)
+| log_command(p)
+| frame_command(p)
 |
 ]
 ;
 
+frame_command(p_tree	*p;)
+:
+  FRAME 
+  [			{ *p = mknode(OP_FRAME, (p_tree) 0); }
+  | count(p)		{ *p = mknode(OP_FRAME, *p); }
+  | '-' count(p)	{ *p = mknode(OP_DOWN, *p); }
+  | '+' count(p)	{ *p = mknode(OP_UP, *p); }
+  ]
+;
+
+source_command(p_tree *p;)
+:
+  SOURCE		{ extended_charset = 1; }
+  name(p)		{ (*p)->t_idf = str2idf((*p)->t_str, 0); }
+  			{ *p = mknode(OP_SOURCE, *p);
+			  extended_charset = 0;
+			}
+;
+
+log_command(p_tree *p;)
+:
+  LOG			{ extended_charset = 1; }
+  [ name(p)		{ (*p)->t_idf = str2idf((*p)->t_str, 0); }
+  |			{ *p = 0; }
+  ]
+  			{ *p = mknode(OP_LOG, *p);
+			  extended_charset = 0;
+			}
+;
 
 where_command(p_tree *p;)
 :
-  WHERE			{ *p = mknode(OP_WHERE, (p_tree) 0); }
-  [ count(&(*p)->t_args[0])?
-  | '-' count(&(*p)->t_args[0])
-			{ (*p)->t_args[0]->t_ival = - (*p)->t_args[0]->t_ival; }
-  ]
+  WHERE opt_num(p)	{ *p = mknode(OP_WHERE, *p); }
 ;
 
 list_command(p_tree *p;)
@@ -161,6 +190,7 @@ help_command(p_tree *p;)
   			{ *p = mknode(OP_HELP, (p_tree) 0); }
   [ name(&(*p)->t_args[0])?
   | '?'			{ (*p)->t_args[0] = mknode(OP_NAME, str2idf("help",0), (char *) 0); }
+  | '!'			{ (*p)->t_args[0] = mknode(OP_NAME, (struct idf *) 0, "!"); }
   ]
 ;
 
@@ -175,6 +205,9 @@ run_command(p_tree *p;)
 			  }
 			  else *p = run_command;
 			}
+  [ '?'			{ *p = mknode(OP_PRCOMM, *p); }
+  |
+  ]
 ;
 
 stop_command(p_tree *p;)
@@ -447,6 +480,15 @@ count(p_tree *p;)
   INTEGER		{ *p = mknode(OP_INTEGER, tok.ival); }
 ;
 
+opt_num(p_tree *p;)
+:
+  count(p)
+|
+  '-' count(p)		{ (*p)->t_ival = - (*p)->t_ival; }
+|
+			{ *p = 0; }
+;
+
 qualified_name(p_tree *p;)
 :
   name(p)
@@ -487,6 +529,9 @@ name(p_tree *p;)
   | HELP
   | DISABLE
   | ENABLE
+  | SOURCE
+  | FRAME
+  | LOG
   ]			{ *p = mknode(OP_NAME, tok.idf, tok.str); }
 ;
 
diff --git a/util/grind/do_comm.c b/util/grind/do_comm.c
index 1be86d1b9..41b394b75 100644
--- a/util/grind/do_comm.c
+++ b/util/grind/do_comm.c
@@ -25,6 +25,12 @@ extern int	interrupted;
 
 p_tree		print_command;
 
+/*ARGSUSED*/
+do_noop(p)
+  p_tree	p;
+{
+}
+
 /* ------------------------------------------------------------- */
 
 /* implementation of the help command */
@@ -49,9 +55,27 @@ do_help(p)
 	fputs("  <wsize> is the last <cnt> given, or 10.\n", db_out);
 	return;
   case XFILE:
-	fputs("file [ <name> ]\n", db_out);
+	fputs("file [ <name> | ? ]\n", db_out);
 	fputs("  Print the name of the current source file, or change the\n", db_out);
-	fputs("  current source file to <name>.\n", db_out);
+	fputs("  current source file to <name>, or print the files that\n", db_out);
+	fputs("  the debugger knows about.\n", db_out);
+	return;
+  case SOURCE:
+	fputs("source <filename>\n", db_out);
+	fputs("  Read commands from the file <filename>\n", db_out);
+	return;
+  case FRAME:
+	fputs("frame [ [ + | - ] <num> ]\n", db_out);
+	fputs("  Sets the 'current' frame to frame <num>. The currently active\n", db_out);
+	fputs("  procedure has frame 0. If <num> is not given, print the 'current' frame.\n", db_out);
+	fputs("  If <num> is given with a + or -, go up or down <num> frames relative\n", db_out);
+	fputs("  to the current one.\n", db_out);
+	return;
+  case LOG:
+	fputs("log [ <name> | off ]\n", db_out);
+	fputs("  Creates a logfile <name> of the commands given.\n", db_out);
+	fputs("  When no argument is given, the current logfile is printed.\n", db_out);
+	fputs("  If the argument is 'off', logging is turned off.\n", db_out);
 	return;
   case RUN:
 	fputs("run [ <args> ] [ < <infile> ] [ > <outfile> ]\n", db_out);
@@ -59,8 +83,9 @@ do_help(p)
 	fputs("  possible redirection of standard input and/or standard output.\n", db_out);
 	return;
   case RERUN:
-	fputs("rerun\n", db_out);
-	fputs("  repeats the last run command.\n", db_out);
+	fputs("rerun [ ? ]\n", db_out);
+	fputs("  If the ? is given, prints the last run command;\n", db_out);
+	fputs("  otherwise repeats the last run command.\n", db_out);
 	return;
   case STOP:
 	fputs("stop [ <pos> ] [ if <cond> ]\n", db_out);
@@ -112,9 +137,9 @@ do_help(p)
 	fputs("  Assign the value of <exp> to <desig>.\n", db_out);
 	return;
   case PRINT:
-	fputs("print <exp> [ , <exp> ] ...\n", db_out);
-	fputs("p <exp> [ , <exp> ] ...\n", db_out);
-	fputs("  Print the value of each <exp>.\n", db_out);
+	fputs("print [ <exp> [ , <exp> ] ...]\n", db_out);
+	fputs("p [ <exp> [ , <exp> ] ...]\n", db_out);
+	fputs("  Print the value of each <exp>, or repeat the last print command\n", db_out);
 	return;
   case DISPLAY:
 	fputs("display <exp> [ , <exp> ] ...\n", db_out);
@@ -160,22 +185,32 @@ do_help(p)
 	fputs("  If no <num> is given, enable the current stopping point (not effective).\n", db_out);
 	return;
   }
+  else if (p && p->t_str) {
+	if (! strcmp(p->t_str, "!")) {
+		fputs("! <shell command>\n", db_out);
+		fputs("  Execute the given shell command.\n", db_out);
+		return;
+	}
+  }
   fputs("cont [ <cnt> ] [ at <line> ]\n", db_out);
   fputs("delete [ <num> [ , <num> ] ... ]\n", db_out);
   fputs("disable [ <num> [ , <num> ] ... ]\n", db_out);
   fputs("display <exp> [ , <exp> ] ...\n", db_out);
   fputs("dump\n", db_out);
   fputs("enable [ <num> [ , <num> ] ... ]\n", db_out);
-  fputs("file [ <name> ]\n", db_out);
+  fputs("file [ <name> | ? ]\n", db_out);
   fputs("find <name>\n", db_out);
+  fputs("frame [ [ + | - ] <num> ]\n", db_out);
   fputs("help [ <commandname> ]\n", db_out);
   fputs("list [ <start> | <func> ] [ , <cnt> | - [ <end> ] ]\n", db_out);
+  fputs("log [ <name> | off ]\n", db_out);
   fputs("next [ <cnt> ]\n", db_out);
-  fputs("print <exp> [ , <exp> ] ...\n", db_out);
-  fputs("rerun\n", db_out);
-  fputs("restore <num>\n", db_out);
+  fputs("print [ <exp> [ , <exp> ] ... ]\n", db_out);
+  fputs("rerun [ ? ]\n", db_out);
+  fputs("restore [ <num> ]\n", db_out);
   fputs("run [ <args> ] [ < <infile> ] [ > <outfile> ]\n", db_out);
   fputs("set <desig> to <exp>\n", db_out);
+  fputs("source <filename>\n", db_out);
   fputs("status\n", db_out);
   fputs("step [ <cnt> ]\n", db_out);
   fputs("stop [ <pos> ] [ if <cond> ]\n", db_out);
@@ -183,6 +218,7 @@ do_help(p)
   fputs("when [ <pos> ] [ if <cond> ] { <command> [ ; <command> ] ... } \n", db_out);
   fputs("where [ <cnt> ]\n", db_out);
   fputs("which <name>\n", db_out);
+  fputs("! <shell command>\n", db_out);
 }
 
 /* ------------------------------------------------------------- */
@@ -608,6 +644,30 @@ do_regs(p)
 
 /* implementation of the where command */
 
+static t_addr	where_PC;
+
+static int
+where_entry(num)
+  int	num;
+{
+  t_addr *buf;
+  t_addr AB;
+  p_scope sc;
+
+  if (! (buf = get_EM_regs(num))) return 0;
+  AB = buf[1];
+  where_PC = buf[2];
+  if (! AB) return 0;
+  sc = base_scope(get_scope_from_addr(where_PC));
+  if (! sc || sc->sc_start > where_PC) return 0;
+  fprintf(db_out, "%s(", sc->sc_definedby->sy_idf->id_text);
+  print_params(sc->sc_definedby->sy_type, AB, has_static_link(sc));
+  fputs(") ", db_out);
+  print_position(where_PC, 0);
+  fputs("\n", db_out);
+  return 1;
+}
+
 /*ARGSUSED*/
 do_where(p)
   p_tree	p;
@@ -636,20 +696,8 @@ do_where(p)
   }
   else if (p) maxcnt = p->t_ival;
   for (cnt = maxcnt; cnt != 0; cnt--) {
-	t_addr AB;
-
 	if (interrupted) return;
-	if (! (buf = get_EM_regs(i++))) break;
-	AB = buf[1];
-	PC = buf[2];
-	if (! AB) break;
-	sc = base_scope(get_scope_from_addr(PC));
-	if (! sc || sc->sc_start > PC) break;
-	fprintf(db_out, "%s(", sc->sc_definedby->sy_idf->id_text);
-	print_params(sc->sc_definedby->sy_type, AB, has_static_link(sc));
-	fputs(") ", db_out);
-	print_position(PC, 0);
-	fputs("\n", db_out);
+	if (! where_entry(i++)) return;
   }
 }
 
@@ -735,7 +783,7 @@ do_print(p)
 	break;
   default:
 	if (interrupted || ! eval_expr(p, &buf, &size, &tp)) return;
-	print_node(p, 0);
+	print_node(db_out, p, 0);
 	fputs(" = ", db_out);
 	if (p->t_oper == OP_FORMAT) {
 		format = p->t_args[1]->t_str;
@@ -774,3 +822,155 @@ do_set(p)
   free(buf);
 }
 
+/* ------------------------------------------------------------- */
+
+/* implementation of the source command */
+
+extern FILE	*db_in;
+
+do_source(p)
+  p_tree	p;
+{
+  FILE		*old_db_in = db_in;
+
+  p = p->t_args[0];
+  if ((db_in = fopen(p->t_str, "r")) == NULL) {
+	db_in = old_db_in;
+	error("could not open %s", p->t_str);
+	return;
+  }
+  Commands();
+  fclose(db_in);
+  db_in = old_db_in;
+}
+
+/* ------------------------------------------------------------- */
+
+do_prcomm(p)
+  p_tree	p;
+{
+  print_node(db_out, p->t_args[0], 1);
+}
+
+/* ------------------------------------------------------------- */
+
+/* stack frame commands: frame, down, up */
+
+extern int	stack_offset;
+
+static
+frame_pos(diff)
+  int	diff;
+{
+  if (stack_offset+diff < 0) diff = - stack_offset;
+  if (! where_entry(stack_offset+diff)) {
+	error("no frame %d", stack_offset+diff);
+	return;
+  }
+  stack_offset += diff;
+  list_position(get_position_from_addr(where_PC));
+  CurrentScope = get_scope_from_addr(where_PC);
+}
+
+do_frame(p)
+  p_tree	p;
+{
+  if (p->t_args[0]) {
+	frame_pos((int) p->t_args[0]->t_ival - stack_offset);
+  }
+  else frame_pos(0);
+}
+
+do_up(p)
+  p_tree	p;
+{
+  if (p->t_args[0]) {
+	frame_pos((int) p->t_args[0]->t_ival);
+  }
+  else frame_pos(1);
+}
+
+do_down(p)
+  p_tree	p;
+{
+  if (p->t_args[0]) {
+	frame_pos(-(int) p->t_args[0]->t_ival);
+  }
+  else frame_pos(-1);
+}
+
+/* ------------------------------------------------------------- */
+
+/* log command */
+
+static char	*logfile;
+static FILE	*logfd;
+
+do_log(p)
+  p_tree	p;
+{
+  p = p->t_args[0];
+  if (p) {
+	if (logfd && ! strcmp(p->t_str, "off")) {
+		fprintf(db_out, "stopped logging on %s\n", logfile);
+		fclose(logfd);
+		logfd = NULL;
+		return;
+	}
+	if (logfd) {
+		error("already logging on %s", logfile);
+		return;
+	}
+	logfile = p->t_str;
+	if ((logfd = fopen(logfile, "w")) == NULL) {
+		error("could not open %s", logfile);
+		return;
+	}
+	fprintf(db_out, "started logging on %s\n", logfile);
+  }
+  else if (logfd) {
+	fprintf(db_out, "the current logfile is %s\n", logfile);
+  }
+  else {
+	error("no current logfile");
+  }
+}
+
+extern int	item_count;
+extern int	in_wheninvoked;
+
+log(p)
+  p_tree	p;
+{
+  register p_tree	p1;
+
+  if (logfd && ! in_wheninvoked) {
+	switch(p->t_oper) {
+	case OP_SOURCE:
+	case OP_LOG:
+		break;
+	case OP_DELETE:
+	case OP_ENABLE:
+	case OP_DISABLE:
+		/* Change absolute item numbers into relative ones
+		   for safer replay
+		*/
+		p1 = p->t_args[0];
+		while (p1 && p1->t_oper == OP_LINK) {
+			register p_tree	p2 = p1->t_args[0];
+			if (p2->t_ival > 0) {
+				p2->t_ival = item_count - p2->t_ival;
+			}
+			p1 = p1->t_args[1];
+		}
+		if (p1 && p1->t_ival > 0) {
+			p1->t_ival = item_count - p1->t_ival;
+		}
+		/* Fall through */
+	default:
+		print_node(logfd, p, 1);
+		fflush(logfd);
+		break;
+	}
+  }
+}
diff --git a/util/grind/expr.c b/util/grind/expr.c
index 40cf34c52..92ae22e59 100644
--- a/util/grind/expr.c
+++ b/util/grind/expr.c
@@ -1197,7 +1197,7 @@ eval_desig(p, paddr, psize, ptp)
 		}
 		break;
 	default:
-		print_node(p, 0);
+		print_node(db_out, p, 0);
 		fputs(" not a designator\n", db_out);
 		break;
 	}
@@ -1216,7 +1216,7 @@ eval_desig(p, paddr, psize, ptp)
 		}
 		break;
 	default:
-		print_node(p, 0);
+		print_node(db_out, p, 0);
 		fputs(" not a designator\n", db_out);
 		break;
 	}
@@ -1233,7 +1233,7 @@ eval_desig(p, paddr, psize, ptp)
 		*ptp = (*ptp)->ty_cross;
 		if (! *ptp) {
 			*ptp = void_type;
-			print_node(p, 0);
+			print_node(db_out, p, 0);
 			fputs(" designator has unknown type\n", db_out);
 			retval = 0;
 			*psize = 0;
diff --git a/util/grind/itemlist.cc b/util/grind/itemlist.cc
index d36410a5d..dd1959fee 100644
--- a/util/grind/itemlist.cc
+++ b/util/grind/itemlist.cc
@@ -24,10 +24,10 @@ typedef struct item {
 
 struct itemlist {
   p_item	il_first, il_last;
-  int		il_count;
 };
 
 static struct itemlist	item_list;
+int		item_count;
 
 static int
 in_item_list(p)
@@ -47,7 +47,7 @@ pr_item(i)
   p_item	i;
 {
   fprintf(db_out, "(%d)\t", i->i_itemno);
-  print_node(i->i_node, 0);
+  print_node(db_out, i->i_node, 0);
   fputs(i->i_disabled ? " (disabled)\n": "\n", db_out);
 }
 
@@ -143,7 +143,7 @@ add_to_item_list(p)
   else {
 	item_list.il_last->i_next = i;
   }
-  i->i_itemno = ++item_list.il_count;
+  i->i_itemno = ++item_count;
   item_list.il_last = i;
   pr_item(i);
   return 1;
@@ -156,6 +156,7 @@ remove_from_item_list(n)
   register p_item i = item_list.il_first, prev = 0;
   p_tree	p;
 
+  if (n <= 0) n = item_count - n;
   while (i) {
 	if (i->i_itemno == n) break;
 	prev = i;
@@ -184,6 +185,7 @@ get_from_item_list(n)
 {
   register p_item i = item_list.il_first;
 
+  if (n <= 0) n = item_count - n;
   while (i) {
 	if (i->i_itemno == n) return i->i_node;
 	i = i->i_next;
@@ -197,6 +199,7 @@ able_item(n, kind)
   register p_item i = item_list.il_first;
   register p_tree p;
 
+  if (n <= 0) n = item_count - n;
   while (i) {
 	if (i->i_itemno == n) break;
 	i = i->i_next;
diff --git a/util/grind/main.c b/util/grind/main.c
index 665f5b83d..4d097b73e 100644
--- a/util/grind/main.c
+++ b/util/grind/main.c
@@ -2,6 +2,7 @@
 
 #include <stdio.h>
 #include <varargs.h>
+#include <signal.h>
 
 #include "tokenname.h"
 #include "position.h"
@@ -77,6 +78,7 @@ main(argc, argv)
   }
   prompt();
   Commands();
+  signal_child(SIGKILL);
   if (eof_seen) putc('\n', db_out);
   exit(0);
 }
diff --git a/util/grind/modula-2.c b/util/grind/modula-2.c
index ac5569530..293aae4dd 100644
--- a/util/grind/modula-2.c
+++ b/util/grind/modula-2.c
@@ -77,7 +77,8 @@ print_char(c)
 }
 
 static int
-print_string(s, len)
+print_string(f, s, len)
+  FILE	*f;
   char	*s;
   int	len;
 {
@@ -87,7 +88,7 @@ print_string(s, len)
   while (*str) {
 	if (*str++ == '\'') delim = '"';
   }
-  fprintf(db_out, "%c%.*s%c", delim, len, s, delim);
+  fprintf(f, "%c%.*s%c", delim, len, s, delim);
 }
 
 extern long	int_size;
@@ -457,92 +458,93 @@ get_string(c)
 }
 
 static int
-print_op(p)
+print_op(f, p)
+  FILE		*f;
   p_tree	p;
 {
   switch(p->t_oper) {
   case OP_UNOP:
   	switch(p->t_whichoper) {
 	case E_MIN:
-		fputs("-", db_out);
-		print_node(p->t_args[0], 0);
+		fputs("-", f);
+		print_node(f, p->t_args[0], 0);
 		break;
 	case E_PLUS:
-		fputs("+", db_out);
-		print_node(p->t_args[0], 0);
+		fputs("+", f);
+		print_node(f, p->t_args[0], 0);
 		break;
 	case E_NOT:
-		fputs("~", db_out);
-		print_node(p->t_args[0], 0);
+		fputs("~", f);
+		print_node(f, p->t_args[0], 0);
 		break;
 	case E_DEREF:
-		print_node(p->t_args[0], 0);
-		fputs("^", db_out);
+		print_node(f, p->t_args[0], 0);
+		fputs("^", f);
 		break;
 	}
 	break;
   case OP_BINOP:
 	if (p->t_whichoper == E_ARRAY) {
-		print_node(p->t_args[0], 0);
-		fputs("[", db_out);
-		print_node(p->t_args[1], 0);
-		fputs("]", db_out);
+		print_node(f, p->t_args[0], 0);
+		fputs("[", f);
+		print_node(f, p->t_args[1], 0);
+		fputs("]", f);
 		break;
 	}
 	if (p->t_whichoper == E_SELECT) {
-		print_node(p->t_args[0], 0);
-		fputs(".", db_out);
-		print_node(p->t_args[1], 0);
+		print_node(f, p->t_args[0], 0);
+		fputs(".", f);
+		print_node(f, p->t_args[1], 0);
 		break;
 	}
-	fputs("(", db_out);
-	print_node(p->t_args[0], 0);
+	fputs("(", f);
+	print_node(f, p->t_args[0], 0);
 	switch(p->t_whichoper) {
 	case E_AND:
-		fputs("&", db_out);
+		fputs("&", f);
 		break;
 	case E_OR:
-		fputs("|", db_out);
+		fputs("|", f);
 		break;
 	case E_DIV:
-		fputs("/", db_out);
+		fputs("/", f);
 		break;
 	case E_MOD:
-		fputs(" MOD ", db_out);
+		fputs(" MOD ", f);
 		break;
 	case E_IN:
-		fputs(" IN ", db_out);
+		fputs(" IN ", f);
 		break;
 	case E_PLUS:
-		fputs("+", db_out);
+		fputs("+", f);
 		break;
 	case E_MIN:
-		fputs("-", db_out);
+		fputs("-", f);
 		break;
 	case E_MUL:
-		fputs("*", db_out);
+		fputs("*", f);
 		break;
 	case E_EQUAL:
-		fputs("=", db_out);
+		fputs("=", f);
 		break;
 	case E_NOTEQUAL:
-		fputs("#", db_out);
+		fputs("#", f);
 		break;
 	case E_LTEQUAL:
-		fputs("<=", db_out);
+		fputs("<=", f);
 		break;
 	case E_GTEQUAL:
-		fputs(">=", db_out);
+		fputs(">=", f);
 		break;
 	case E_LT:
-		fputs("<", db_out);
+		fputs("<", f);
 		break;
 	case E_GT:
-		fputs(">", db_out);
+		fputs(">", f);
 		break;
 	}
-	print_node(p->t_args[1], 0);
-	fputs(")", db_out);
+	print_node(f, p->t_args[1], 0);
+	fputs(")", f);
 	break;
   }
 }
diff --git a/util/grind/operators.ot b/util/grind/operators.ot
index d28f1d795..d77334d55 100644
--- a/util/grind/operators.ot
+++ b/util/grind/operators.ot
@@ -34,3 +34,10 @@ OP_BINOP	2	0
 OP_FORMAT	2	0
 OP_DISABLE	1	do_disable
 OP_ENABLE	1	do_enable
+OP_SHELL	0	do_noop
+OP_SOURCE	1	do_source
+OP_PRCOMM	1	do_prcomm
+OP_UP		1	do_up
+OP_DOWN		1	do_down
+OP_FRAME	1	do_frame
+OP_LOG		1	do_log
diff --git a/util/grind/position.h b/util/grind/position.h
index a2cb0bbf1..58cf0b659 100644
--- a/util/grind/position.h
+++ b/util/grind/position.h
@@ -7,7 +7,7 @@
 typedef unsigned int	t_lineno;
 typedef long		t_addr;
 #define ILL_ADDR	((t_addr) -1)
-#define NO_ADDR		((t_addr) -3)
+#define NO_ADDR		((t_addr) 0)
 
 typedef struct pos {
   t_lineno	lineno;
diff --git a/util/grind/print.c b/util/grind/print.c
index 144099097..6e0e345cb 100644
--- a/util/grind/print.c
+++ b/util/grind/print.c
@@ -283,21 +283,37 @@ print_val(tp, tp_sz, addr, compressed, indent, format)
 	}
 	fprintf(db_out, currlang->addr_fmt, get_int(addr, pointer_size, T_UNSIGNED));
 	break;
-  case T_POINTER:
-	if (format && strindex(format,'s') &&
+  case T_POINTER: {
+	t_addr a = get_int(addr, tp_sz, T_UNSIGNED);
+
+	fprintf(db_out, currlang->addr_fmt, a);
+	if (format && strindex(format, 's') &&
 	    (tp->ty_ptrto == char_type || tp->ty_ptrto == uchar_type)) {
-		t_addr a = get_int(addr, tp_sz, T_UNSIGNED);
 		char *naddr = malloc(512);
 
-		if (naddr && get_string(511L, a, naddr)) {
-			print_val(string_type, 512L, naddr, 0, indent, format);
+		if (! naddr) {
+			fputs(" (could not allocate memory)", db_out);
+			break;
+		}
+		if (! get_string(511L, a, naddr)) {
+			fputs(" (not a valid pointer)", db_out);
 			free(naddr);
 			break;
 		}
-		if (naddr) free(naddr);
+		fputs(" (", db_out);
+		print_val(string_type, 512L, naddr, 0, indent, format);
+		fputs(")", db_out);
+		free(naddr);
+		break;
+	}
+	if (tp->ty_ptrto->ty_class == T_PROCEDURE) {
+		p_scope sc = get_scope_from_addr(a);
+		if (sc && sc->sc_definedby && a == sc->sc_start) {
+			fprintf(db_out, " (%s)", sc->sc_definedby->sy_idf->id_text);
+		}
 	}
-	fprintf(db_out, currlang->addr_fmt, get_int(addr, pointer_size, T_UNSIGNED));
 	break;
+	}
   case T_FILE:
 	fprintf(db_out, "<file>");
 	break;
@@ -363,7 +379,7 @@ print_val(tp, tp_sz, addr, compressed, indent, format)
 	print_integer(tp, get_int(addr, tp_sz, T_INTEGER), format);
 	break;
   case T_STRING:
-	(*currlang->printstring)(addr, (int) tp_sz);
+	(*currlang->printstring)(db_out, addr, (int) tp_sz);
 	break;
   default:
 	assert(0);
diff --git a/util/grind/run.c b/util/grind/run.c
index e5b1a0e22..937aa6ff4 100644
--- a/util/grind/run.c
+++ b/util/grind/run.c
@@ -31,6 +31,7 @@ extern char	*progname;
 extern int	child_interrupted;
 extern int	interrupted;
 extern int	stop_reason;
+extern int	stack_offset;
 extern t_lineno	currline;
 
 static int	child_pid;		/* process id of child */
@@ -386,6 +387,7 @@ could_send(m, stop_message)
 	if (m->m_type & M_DB_RUN) {
 		disable_intr = 0;
 		stop_reason = 0;
+		stack_offset = 0;
 	}
 	if (!child_interrupted && (! uputm(m) || ! ugetm(&answer))) {
 		child_dead = 1;
@@ -458,10 +460,12 @@ could_send(m, stop_message)
 }
 
 static int
-getbytes(size, from, to, kind)
+getbytes(size, from, to, kind, errmess)
   long	size;
   t_addr from;
   char	*to;
+  int kind;
+  int errmess;
 {
   struct message_hdr	m;
 
@@ -475,10 +479,10 @@ getbytes(size, from, to, kind)
 
   switch(answer.m_type) {
   case M_FAIL:
-	error("could not get value");
+	if (errmess) error("could not get value");
 	return 0;
   case M_INTR:
-	error("interrupted");
+	if (errmess) error("interrupted");
 	return 0;
   case M_DATA:
   	return ureceive(to, BUFTOI(answer.m_buf+1, (int)LS));
@@ -494,7 +498,7 @@ get_bytes(size, from, to)
   t_addr from;
   char	*to;
 {
-  return getbytes(size, from, to, M_GETBYTES);
+  return getbytes(size, from, to, M_GETBYTES, 1);
 }
 
 int
@@ -503,7 +507,7 @@ get_string(size, from, to)
   t_addr from;
   char	*to;
 {
-  int retval = getbytes(size, from, to, M_GETSTR);
+  int retval = getbytes(size, from, to, M_GETSTR, 0);
 
   to[(int)BUFTOI(answer.m_buf+1, (int)LS)] = 0;
   return retval;
diff --git a/util/grind/tokenname.c b/util/grind/tokenname.c
index c19b529be..9d6fb7a3c 100644
--- a/util/grind/tokenname.c
+++ b/util/grind/tokenname.c
@@ -60,6 +60,9 @@ struct tokenname tkidf[] =	{	/* names of the identifier tokens */
 	{HELP, "help"},
 	{DISABLE,"disable"},
 	{ENABLE,"enable"},
+	{SOURCE, "source"},
+	{FRAME, "frame"},
+	{LOG, "log"},
 	{-1, "quit"},
 	{0, ""}
 };
diff --git a/util/grind/tree.c b/util/grind/tree.c
index 6edc2b06d..fb5e1077e 100644
--- a/util/grind/tree.c
+++ b/util/grind/tree.c
@@ -151,200 +151,239 @@ get_addr_from_node(p)
   return a;
 }
 
-print_node(p, top_level)
+static int	ommit_commas = 0;
+
+print_node(f, p, top_level)
   register p_tree	p;
+  register FILE		*f;
 {
   if (!p) return;
   switch(p->t_oper) {
+  case OP_LOG:
+	fputs("log ", f);
+	print_node(f, p->t_args[0], 0);
+	break;
+  case OP_PRCOMM:
+	fputs("rerun ?", f);
+	break;
+  case OP_RUN:
+	fputs("run ", f);
+	ommit_commas = 1;
+	print_node(f, p->t_args[0], 0);
+	ommit_commas = 0;
+	break;
   case OP_LIST:
-	fputs("list ", db_out);
+	fputs("list ", f);
 	if (p->t_args[0]) {
-		print_node(p->t_args[0], 0);
+		print_node(f, p->t_args[0], 0);
 		if (p->t_args[1]) {
 			if (p->t_args[1]->t_ival >= 0) {
-				fputs(", ", db_out);
-				print_node(p->t_args[1], 0);
+				fputs(", ", f);
+				print_node(f, p->t_args[1], 0);
 			}
 			else  {
 				if (p->t_args[1]->t_ival < -100000000) {
-					fputs("-", db_out);
+					fputs("-", f);
 				}
-				else print_node(p->t_args[1], 0);
+				else print_node(f, p->t_args[1], 0);
 			}
 		}
 	}
 	break;
   case OP_PRINT:
-	fputs("print ", db_out);
-	print_node(p->t_args[0], 0);
+	fputs("print ", f);
+	print_node(f, p->t_args[0], 0);
+	break;
+  case OP_SOURCE:
+	fputs("source ", f);
+	print_node(f, p->t_args[0], 0);
 	break;
   case OP_ENABLE:
-	fputs("enable ", db_out);
-	print_node(p->t_args[0], 0);
+	fputs("enable ", f);
+	print_node(f, p->t_args[0], 0);
 	break;
   case OP_DISABLE:
-	fputs("disable ", db_out);
-	print_node(p->t_args[0], 0);
+	fputs("disable ", f);
+	print_node(f, p->t_args[0], 0);
 	break;
   case OP_DISPLAY:
-	fputs("display ", db_out);
-	print_node(p->t_args[0], 0);
+	fputs("display ", f);
+	print_node(f, p->t_args[0], 0);
 	break;
   case OP_LINK:
-	print_node(p->t_args[0], 0);
-	fputs(", ", db_out);
-	print_node(p->t_args[1], 0);
+	print_node(f, p->t_args[0], 0);
+	if (! ommit_commas) fputs(", ", f);
+	else putc(' ', f);
+	print_node(f, p->t_args[1], 0);
 	break;
   case OP_FILE:
-	fputs("file ", db_out);
-	print_node(p->t_args[0], 0);
+	fputs("file ", f);
+	print_node(f, p->t_args[0], 0);
+	break;
+  case OP_FRAME:
+	fputs("frame ", f);
+	print_node(f, p->t_args[0], 0);
+	break;
+  case OP_UP:
+	fputs("frame +", f);
+	print_node(f, p->t_args[0], 0);
+	break;
+  case OP_DOWN:
+	fputs("frame -", f);
+	print_node(f, p->t_args[0], 0);
 	break;
   case OP_SET:
-	fputs("set ", db_out);
-	print_node(p->t_args[0], 0);
-	fputs(" to ", db_out);
-	print_node(p->t_args[1], 0);
+	fputs("set ", f);
+	print_node(f, p->t_args[0], 0);
+	fputs(" to ", f);
+	print_node(f, p->t_args[1], 0);
 	break;
   case OP_FIND:
-	fputs("find ", db_out);
-	print_node(p->t_args[0], 0);
+	fputs("find ", f);
+	print_node(f, p->t_args[0], 0);
 	break;
   case OP_WHICH:
-	fputs("which ", db_out);
-	print_node(p->t_args[0], 0);
+	fputs("which ", f);
+	print_node(f, p->t_args[0], 0);
 	break;
   case OP_DELETE:
-	fputs("delete ", db_out);
-	print_node(p->t_args[0], 0);
+	fputs("delete ", f);
+	print_node(f, p->t_args[0], 0);
 	break;
   case OP_REGS:
-	fputs("regs ", db_out);
-	print_node(p->t_args[0], 0);
+	fputs("regs ", f);
+	print_node(f, p->t_args[0], 0);
 	break;
   case OP_NEXT:
-	fputs("next ", db_out);
-	print_node(p->t_args[0], 0);
+	fputs("next ", f);
+	print_node(f, p->t_args[0], 0);
 	break;
   case OP_STEP:
-	fputs("step ", db_out);
-	print_node(p->t_args[0], 0);
+	fputs("step ", f);
+	print_node(f, p->t_args[0], 0);
 	break;
   case OP_STATUS:
-	fputs("status", db_out);
+	fputs("status", f);
 	break;
   case OP_DUMP:
-	fputs("dump ", db_out);
+	fputs("dump ", f);
 	print_position(p->t_address, 1);
 	break;
   case OP_RESTORE:
-	fputs("restore ", db_out);
-	print_node(p->t_args[0], 0);
+	fputs("restore ", f);
+	print_node(f, p->t_args[0], 0);
 	break;
   case OP_WHERE:
-	fputs("where ", db_out);
-	print_node(p->t_args[0], 0);
+	fputs("where ", f);
+	print_node(f, p->t_args[0], 0);
 	break;
   case OP_HELP:
-	fputs("help ", db_out);
-	print_node(p->t_args[0], 0);
+	fputs("help ", f);
+	print_node(f, p->t_args[0], 0);
 	break;
   case OP_CONT:
-	fputs("cont", db_out);
+	fputs("cont", f);
 	if (p->t_args[0]) {
-		fprintf(db_out, " %ld", p->t_args[0]->t_ival);
+		fprintf(f, " %ld", p->t_args[0]->t_ival);
 	}
 	if (p->t_args[1]) {
-		fputs(" ", db_out);
-		print_node(p->t_args[1], 0);
+		fputs(" ", f);
+		print_node(f, p->t_args[1], 0);
 	}
 	break;
 
   case OP_WHEN:
-	fputs("when ", db_out);
+	fputs("when ", f);
 	if (p->t_address != NO_ADDR) {
 		print_position(p->t_address, 1);
 	}
-	else print_node(p->t_args[0], 0);
+	else print_node(f, p->t_args[0], 0);
 	if (p->t_args[1]) {
-		fputs(" if ", db_out);
-		print_node(p->t_args[1], 0);
+		fputs(" if ", f);
+		print_node(f, p->t_args[1], 0);
 	}
 	p = p->t_args[2];
-	fputs(" { ", db_out);
+	fputs(" { ", f);
 	while (p && p->t_oper == OP_LINK) {
-		print_node(p->t_args[0], 0);
-		fputs("; ", db_out);
+		print_node(f, p->t_args[0], 0);
+		fputs("; ", f);
 		p = p->t_args[1];
 	}
-	print_node(p, 0);
-	fputs(" }", db_out);
+	print_node(f, p, 0);
+	fputs(" }", f);
 	break;
   case OP_STOP:
-	fputs("stop ", db_out);
+	fputs("stop ", f);
 	if (p->t_address != NO_ADDR) {
 		print_position(p->t_address, 1);
 	}
-	else print_node(p->t_args[0], 0);
+	else print_node(f, p->t_args[0], 0);
 	if (p->t_args[1]) {
-		fputs(" if ", db_out);
-		print_node(p->t_args[1], 0);
+		fputs(" if ", f);
+		print_node(f, p->t_args[1], 0);
 	}
 	break;
   case OP_TRACE:
-	fputs("trace ", db_out);
+	fputs("trace ", f);
 	if (p->t_args[2]) {
-		fputs("on ", db_out);
-		print_node(p->t_args[2], 0);
-		fputs(" ", db_out);
+		fputs("on ", f);
+		print_node(f, p->t_args[2], 0);
+		fputs(" ", f);
 	}
 	if (p->t_address != NO_ADDR) {
 		print_position(p->t_address, 1);
 	}
-	else print_node(p->t_args[0], 0);
+	else print_node(f, p->t_args[0], 0);
 	if (p->t_args[1]) {
-		fputs(" if ", db_out);
-		print_node(p->t_args[1], 0);
+		fputs(" if ", f);
+		print_node(f, p->t_args[1], 0);
 	}
 	break;
   case OP_AT:
-	fprintf(db_out, "at \"%s\":%ld", p->t_filename, p->t_lino);
+	fprintf(f, "at \"%s\":%ld", p->t_filename, p->t_lino);
 	break;
   case OP_IN:
-	fputs("in ", db_out);
-	print_node(p->t_args[0], 0);
-	fputs(" ", db_out);
-	print_node(p->t_args[1], 0);
+	fputs("in ", f);
+	print_node(f, p->t_args[0], 0);
+	fputs(" ", f);
+	print_node(f, p->t_args[1], 0);
 	break;
   case OP_SELECT:
-	print_node(p->t_args[0], 0);
-	fputs("`", db_out);
-	print_node(p->t_args[1], 0);
+	print_node(f, p->t_args[0], 0);
+	fputs("`", f);
+	print_node(f, p->t_args[1], 0);
+	break;
+  case OP_OUTPUT:
+	fprintf(f, "> %s ", p->t_str);
+	break;
+  case OP_INPUT:
+	fprintf(f, "< %s ", p->t_str);
 	break;
   case OP_NAME:
-	fputs(p->t_str, db_out);
+	fputs(p->t_str, f);
 	break;
   case OP_INTEGER:
-	fprintf(db_out, currlang->decint_fmt, p->t_ival);
+	fprintf(f, currlang->decint_fmt, p->t_ival);
 	break;
   case OP_STRING:
-	(*currlang->printstring)(p->t_sval, strlen(p->t_sval));
+	(*currlang->printstring)(f, p->t_sval, strlen(p->t_sval));
 	break;
   case OP_REAL:
-	fprintf(db_out, currlang->real_fmt, p->t_fval);
+	fprintf(f, currlang->real_fmt, p->t_fval);
 	break;
   case OP_FORMAT:
-	print_node(p->t_args[0], 0);
-	fputs("\\", db_out);
-	print_node(p->t_args[1], 0);
+	print_node(f, p->t_args[0], 0);
+	fputs("\\", f);
+	print_node(f, p->t_args[1], 0);
 	break;
   case OP_UNOP:
   case OP_BINOP:
-	(*currlang->printop)(p);
+	(*currlang->printop)(f, p);
 	break;
   default:
 	assert(0);
   }
-  if (top_level) fputs("\n", db_out);
+  if (top_level) fputs("\n", f);
 }
 
 int
@@ -377,6 +416,8 @@ in_status(com)
   p_tree	com;
 {
   switch(com->t_oper) {
+  case OP_PRCOMM:
+	/* not really in status but may not be removed */
   case OP_STOP:
   case OP_WHEN:
   case OP_TRACE:
@@ -408,6 +449,8 @@ newfile(id)
   find_language(strrindex(id->id_text, '.'));
 }
 
+int	in_wheninvoked;
+
 perform(p, a)
   register p_tree	p;
   t_addr		a;
@@ -416,6 +459,7 @@ perform(p, a)
   case OP_WHEN:
 	if (p->t_args[1] && ! eval_cond(p->t_args[1])) break;
 	p = p->t_args[2];
+	in_wheninvoked++;
 	while (p && p->t_oper == OP_LINK) {
 		if (interrupted) return;
 		if (p->t_args[0]) eval(p->t_args[0]);
@@ -423,6 +467,7 @@ perform(p, a)
 	}
 	if (interrupted) return;
 	if (p) eval(p);
+	in_wheninvoked--;
 	break;
   case OP_TRACE:
 	if (p->t_args[0] && p->t_args[0]->t_oper == OP_IN) {