Initial version

util/grind/Amakefile

@@ -0,0 +1,141 @@
+AMAKELIB = { . , /usr/local/lib/amake } ;
+
+%include ack-defs.amk ;
+%include common.amk ;
+%include cc_hh_tools.amk ;
+%include tok_tools.amk ;
+%include op_tools.amk ;
+%include char_tools.amk ;
+%include LLgen.amk ;
+%include cc-c.amk ;
+%include loader.amk ;
+%include lint.amk ;
+
+%default grind ;
+
+TOKENNAMES = tokenname.c [
+	gen_tokens,
+	cc-dest = symbol2str.c,
+	LL-dest = tokenfile.g
+];
+
+DBS_LLTARGETS = {
+	dbx_string.c[type=C-src],
+	DBSpars.c[type=C-src],
+	DBSpars.h[type=C-incl]
+} ;
+
+DBS_LLSRC = {
+	dbx_string.g
+} ;
+
+CMD_LLTARGETS = {
+	tokenfile.c[type=C-src],
+	commands.c[type=C-src],
+	Lpars.c[type=C-src],
+	Lpars.h[type=C-incl]
+} ;
+
+CMD_LLSRC = {
+	tokenname.c,
+	commands.g
+} ;
+
+GENNEXTSRC = {
+	file.h[type=C-incl],
+	next.c[type=C-src]
+} ;
+
+CSRC = {
+	dbxread.c,
+	main.c,
+	list.c,
+	tree.c,
+	expr.c,
+	position.c,
+	idf.c,
+	run.c,
+	dump.c,
+	symbol.c,
+	print.c,
+	value.c,
+	type.c,
+	rd.c,
+	modula-2.c
+} ;
+
+HSRC = {
+	tokenname.h,
+	operator.h,
+	class.h,
+	position.h,
+	idf.h,
+	message.h,
+	avl.h,
+	scope.h,
+	langdep.h,
+	sizes.h,
+	rd.h
+} ;
+
+HHSRC = {
+	file.hh,
+	type.hh,
+	symbol.hh,
+	tree.hh,
+	avl.cc,
+	scope.cc,
+	itemlist.cc,
+	langdep.cc
+} ;
+
+LIBRARIES = {
+	$EMHOME/modules/lib/libassert.a,
+	$EMHOME/modules/lib/liballoc.a,
+	$EMHOME/modules/lib/malloc.o,
+	$EMHOME/modules/lib/libstring.a,
+	$EMHOME/modules/lib/libobject.a,
+	$EMHOME/modules/lib/libsystem.a
+} ;
+
+DBFLAGS = { -g, -DDEBUG } ;
+PROFFLAGS = { } ;
+
+LDFLAGS = {
+	-Bstatic,
+	$PROFFLAGS,
+	$DBFLAGS
+} ;
+
+INCLUDES = {
+	-I$EMHOME/modules/h,
+	-I$EMHOME/modules/pkg,
+	-I$EMHOME/h
+} ;
+
+CFLAGS = {
+	$INCLUDES,
+	$PROFFLAGS,
+	$DBFLAGS
+} ;
+
+LINTFLAGS = {
+	$INCLUDES
+} ;
+
+%cluster {
+	%targets $DBS_LLTARGETS ;
+	%sources $DBS_LLSRC ;
+	%use LLgen(prefix => DBS) ;
+} ;
+
+%cluster {
+	%targets lint.out[type = lint-output];
+	%sources $CMD_LLSRC + $CSRC + $DBS_LLTARGETS + $HHSRC + char.ct + operators.ot ;
+	%use lint(realdest => lint.out) ;
+} ;
+
+%cluster {
+	%targets grind[type = program];
+	%sources $CMD_LLSRC + $CSRC + $DBS_LLTARGETS + $HHSRC + char.ct + operators.ot ;
+} ;

util/grind/LLgen.amk

@@ -0,0 +1,40 @@
+# LLgen:	LL(1) parser generator
+# variables:	LLGEN, LLFLAGS
+
+# tool definition for the new version of LLgen that allows for more than
+# one parser in one program. Unfortunately, for historical reasons there
+# is no proper default prefix for LLgen-generated files (LL.output versus
+# Lpars.[ch]). If LLgen would generate LLpars.[ch] instead of Lpars.[ch],
+# we could have a default value for prefix of 'LL', which would make
+# things a bit more simple.
+
+%instance deftypesuffix(LLgen-src, '%.g') ;
+
+%include ack-defs.amk;
+
+%if (%not defined(LLGEN), {
+    LLGEN = $EMHOME/bin/LLgen;
+});
+
+%if (%not defined(LLFLAGS), {
+    LLFLAGS = {};
+});
+
+%tool LLgen (
+    verbose: %boolean			  => %false;
+    flags:   %string %list		  => $LLFLAGS;
+    prefix:  %string			  => '';
+    src:     %in %list  [type = LLgen-src];
+    parser:  %out %list [type = C-src]
+	=> match($src) + if($prefix == '', Lpars.c, $prefix'pars.c');
+    tokens:  %out      [type = C-incl, compare]
+	=> if($prefix == '', Lpars.h, $prefix'pars.h');
+    diagn:   %out      [type = text]
+	=> if($prefix == '', LL.output, $prefix.output) %conform $verbose;
+    cmd:     %in      [type = command]    => $LLGEN;
+)
+{
+    exec($cmd, args => if($verbose, {'-vvv'}, {}) + $flags + $src);
+    echo({'LLgen ', $src, ' done'});
+};
+

util/grind/PROBLEMS

@@ -0,0 +1,6 @@
+- front-end cannot generate DBX symbol table information for bit-fields,
+  because it does not know about byte-order.
+- single stepping on a line by line basis is difficult if you use breakpoints.
+  The problem is where to set the next breakpoint. One solution is to use
+  single-stepping until we are at a different line, but this is probably
+  extremely slow. Another solution is to adapt edb's method.

util/grind/READ_ME

@@ -0,0 +1,3 @@
+This is GRIND (GRind Is Not Dbx). This program is still being developed,
+so behaviour may change without notice.
+

util/grind/ack-defs.amk

@@ -0,0 +1,5 @@
+# definition of EMHOME
+
+%if (%not defined(EMHOME), {
+    EMHOME = /usr/proj/em/Work;
+});

util/grind/avl.cc

@@ -0,0 +1,245 @@
+/* $Header$ */
+
+#include <alloc.h>
+
+/* Implementation of AVL-trees: trees in which the difference in depth
+   of the left branch and the right branch is at most one.
+   The difference in depth is indicated by a "balance" flag in each node:
+   this flag has one of three values:
+   .	indicating that the left branch has the same depth as the right branch,
+   +	indicating that the right branch is deeper,
+   -	indicating that the left branch is deeper.
+   So, a node has the following structure:
+*/
+
+struct avl_node {
+  struct avl_node
+		*left,
+		*right;		/* the left and right branches */
+  char		*info;		/* pointer to information in this node */
+  char		balance;	/* balance information described above */
+};
+
+/* create definitions for new_avl_node() and free_avl_node() */
+/* STATICALLOCDEF "avl_node" 10 */
+
+/* There is also a tree header, which contains the root of the tree and
+   the address of a user-supplied comparison routine:
+*/
+
+struct avl_tree {
+  struct avl_node
+		*root;		/* root of the avl tree */
+  int		(*cmp)();	/* address of comparison routine */
+};
+/* create definitions for new_avl_tree() and free_avl_tree() */
+/* STATICALLOCDEF "avl_tree" 2 */
+
+/* The next routine adds a node to an avl tree. It returns 1 if the
+   tree got deeper.
+*/
+static int
+balance_add(ppsc, n, cmp)
+  struct avl_node **ppsc;	/* address of root */
+  register char *n;		/* user-supplied information */
+  int (*cmp)();			/* user-supplied comparison routine */
+{
+  register struct avl_node *psc = *ppsc, *qsc, *ssc;
+
+  if (! psc) {
+	*ppsc = new_avl_node();
+	(*ppsc)->balance = '.';
+	(*ppsc)->info = n;
+	return 1;
+  }
+  if ((*cmp)(n, psc->info) < 0) {
+	if (balance_add(&(psc->left), n, cmp)) {
+		/* left hand side got deeper */
+		if (psc->balance == '+') {
+			/* but the right hand side was deeper */
+			psc->balance = '.';
+			return 0;
+		}
+		if (psc->balance == '.') {
+			/* but the right hand side was as deep */
+			psc->balance = '-';
+			return 1;
+		}
+		/* left hand side already was one deeper; re-organize */
+		qsc = psc->left;
+		if (qsc->balance == '-') {
+			/* if left-hand side of left node was deeper,
+			   this node becomes the new root
+			*/
+			psc->balance = '.';
+			qsc->balance = '.';
+			psc->left = qsc->right;
+			qsc->right = psc;
+			*ppsc = qsc;
+			return 0;
+		}
+		/* else the right node of the left node becomes the new root */
+		ssc = qsc->right;
+		psc->left = ssc->right;
+		qsc->right = ssc->left;
+		ssc->left = qsc;
+		ssc->right = psc;
+		*ppsc = ssc;
+		if (ssc->balance == '.') {
+			psc->balance = '.';
+			qsc->balance = '.';
+			return 0;
+		}
+		if (ssc->balance == '-') {
+			psc->balance = '+';
+			qsc->balance = '.';
+			ssc->balance = '.';
+			return 0;
+		}
+		psc->balance = '.';
+		qsc->balance = '-';
+	}
+	return 0;
+  }
+  if (balance_add(&(psc->right), n, cmp)) {
+	/* right hand side got deeper */
+	if (psc->balance == '-') {
+		/* but the left hand side was deeper */
+		psc->balance = '.';
+		return 0;
+	}
+	if (psc->balance == '.') {
+		/* but the left hand side as deep */
+		psc->balance = '+';
+		return 1;
+	}
+	/* right hand side already was one deeper; re-organize */
+	qsc = psc->right;
+	if (qsc->balance == '+') {
+		/* if right-hand side of left node was deeper,
+		   this node becomes the new root
+		*/
+		psc->balance = '.';
+		qsc->balance = '.';
+		psc->right = qsc->left;
+		qsc->left = psc;
+		*ppsc = qsc;
+		return 0;
+	}
+	/* else the left node of the right node becomes the new root */
+	ssc = qsc->left;
+	psc->right = ssc->left;
+	qsc->left = ssc->right;
+	ssc->right = qsc;
+	ssc->left = psc;
+	*ppsc = ssc;
+	if (ssc->balance == '.') {
+		psc->balance = '.';
+		qsc->balance = '.';
+		return 0;
+	}
+	if (ssc->balance == '+') {
+		psc->balance = '-';
+		qsc->balance = '.';
+		ssc->balance = '.';
+		return 0;
+	}
+	psc->balance = '.';
+	qsc->balance = '+';
+  }
+  return 0;
+}
+
+/* extern struct avl_tree *create_avl_tree(int (*cmp)());
+   Returns a fresh avl_tree structure.
+*/
+struct avl_tree *
+create_avl_tree(cmp)
+  int	(*cmp)();		/* comparison routine */
+{
+  register struct avl_tree *p = new_avl_tree();
+
+  p->cmp = cmp;
+  return p;
+}
+
+/* extern add_to_avl_tree(struct avl_tree *tree, char *n);
+   Adds the information indicated by 'n' to the avl_tree indicated by 'tree'
+*/
+add_to_avl_tree(tree, n)
+  struct avl_tree	*tree;	/* tree to be added to */
+  char			*n;	/* information */
+{
+  balance_add(&(tree->root), n, tree->cmp);
+}
+
+/* extern char *find_ngt(struct avl_tree *tree, char *n);
+   Returns the information in the largest node that still compares <= to 'n',
+   or 0 if not present.
+*/
+char *
+find_ngt(tree, n)
+  struct avl_tree	*tree;	/* tree to be searched in */
+  char			*n;	/* information to be compared with */
+{
+  register struct avl_node *nd = tree->root, *lastnd = 0;
+
+  for (;;) {
+  	while (nd && (*tree->cmp)(nd->info, n) > 0) {
+		nd = nd->left;
+	}
+  	while (nd && (*tree->cmp)(nd->info, n) <= 0) {
+		lastnd = nd;
+		nd = nd->right;
+	}
+	if (! nd) break;
+  }
+  return lastnd ? lastnd->info : (char *) 0;
+}
+
+/* extern char *find_nlt(struct avl_tree *tree, char *n);
+   Returns the information in the largest node that still compares >= to 'n',
+   or 0 if not present.
+*/
+char *
+find_nlt(tree, n)
+  struct avl_tree	*tree;	/* tree to be searched in */
+  char			*n;	/* information to be compared with */
+{
+  register struct avl_node *nd = tree->root, *lastnd = 0;
+
+  for (;;) {
+  	while (nd && (*tree->cmp)(nd->info, n) < 0) {
+		nd = nd->right;
+	}
+  	while (nd && (*tree->cmp)(nd->info, n) >= 0) {
+		lastnd = nd;
+		nd = nd->left;
+	}
+	if (! nd) break;
+  }
+  return lastnd ? lastnd->info : (char *) 0;
+}
+
+/* extern char *find_eq(struct avl_tree *tree, char *n);
+   Returns the information in the node that compares equal to 'n',
+   or 0 if not present.
+*/
+char *
+find_eq(tree, n)
+  struct avl_tree	*tree;	/* tree to be searched in */
+  char			*n;	/* information to be compared with */
+{
+  register struct avl_node *nd = tree->root;
+
+  for (;;) {
+  	while (nd && (*tree->cmp)(nd->info, n) < 0) {
+		nd = nd->right;
+	}
+  	while (nd && (*tree->cmp)(nd->info, n) > 0) {
+		nd = nd->left;
+	}
+	if (! nd) break;
+  }
+  return nd ? nd->info : (char *) 0;
+}

util/grind/avl.h

@@ -0,0 +1,43 @@
+/* $Header$ */
+
+/* AVL-trees: trees in which the difference in depth
+   of the left branch and the right branch is at most one.
+   Information in the nodes is represented by a pointer, which is to
+   be supplied by the user. The user is also expected to supply a
+   comparison routine for each AVL tree. This routine is offered two
+   parameters, both pointers, and is expected to return:
+   a negative number	if the comparison result is <
+   0 			if the comparison result is =
+   a positive number	if the comparison result is >
+*/
+
+typedef struct avl_tree	*AVL_tree;
+
+/* extern AVL_tree create_avl_tree(int (*cmp)());
+   Returns a fresh avl_tree structure. 'cmp' will be used as comparison
+   routine for this tree.
+*/
+extern AVL_tree create_avl_tree();
+
+/* extern add_to_avl_tree(AVL_tree tree, char *n);
+   Adds the information indicated by 'n' to the avl_tree indicated by 'tree'.
+*/
+extern add_to_avl_tree();
+
+/* extern char *find_ngt(AVL_tree tree, char *n);
+   Returns the information in the largest node that still compares <= to 'n',
+   or 0 if not present.
+*/
+extern char *find_ngt();
+
+/* extern char *find_nlt(AVL_tree tree, char *n);
+   Returns the information in the largest node that still compares >= to 'n',
+   or 0 if not present.
+*/
+extern char *find_nlt();
+
+/* extern char *find_eq(AVL_tree tree, char *n);
+   Returns the information in the node that compares equal to 'n',
+   or 0 if not present.
+*/
+extern char *find_eq();

util/grind/cc_hh_tools.amk

@@ -0,0 +1,43 @@
+%instance deftypesuffix(hh-src, '%.hh') ;
+%instance deftypesuffix(cc-src, '%.cc') ;
+
+ALLOCD = make.allocd;
+NEXT = make.next;
+
+%tool allochd (
+    hhsrc:	%in [type = hh-src, persistent];
+    hsrc:	%out [type = C-incl]	=> match($hhsrc);
+    prog:	%in [type = command]	=> $ALLOCD;
+)
+{
+    exec($prog, stdin => $hhsrc, stdout => $hsrc);
+    echo({$hsrc ,'created'});
+};
+
+
+%tool alloccd (
+    ccsrc:	%in [type = cc-src, persistent];
+    csrc:	%out [type = C-src]	=> match($ccsrc);
+    prog:	%in [type = command]	=> $ALLOCD;
+)
+{
+    exec($prog, stdin => $ccsrc, stdout => $csrc);
+    echo({$csrc ,'created'});
+};
+
+
+# Possibly there's only one type of { cc-src, hh-src } available,
+# so introduce a new attribute.
+
+%derive f[cc-or-hh-src] %when get($f, type) == cc-src
+			%or   get($f, type) == hh-src;
+
+%tool mknext (
+    cchhsrc:	%in %list [cc-or-hh-src];
+    next:	%out [type = C-src]	=> next.c;
+    prog:	%in [type = command]	=> $NEXT;
+)
+{
+    exec($prog, args => $cchhsrc, stdout => $next);
+    echo({$next ,'created'});
+};

util/grind/char.ct

@@ -0,0 +1,71 @@
+% character tables for debugger
+% $Header$
+%S257
+%F	%s,
+%
+%	CHARACTER CLASSES
+%
+%iSTGARB
+STSKIP: \t\013\014\015
+STNL:;\012
+STIDF:a-zA-Z_$
+STSTR:"'
+STDOT:.
+STNUM:0-9
+STSIMP:,<>{}:`
+%T#include "class.h"
+%Tchar tkclass[] = {
+%p
+%T};
+%
+%	INIDF
+%
+%S129
+%C
+1:a-zA-Z0-9_$
+%Tchar inidf[] = {
+%F	%s,
+%p
+%T};
+%
+%	INEXT
+%
+%S129
+%C
+1:-#+{}~`@%^=|\\;:?/,a-zA-Z0-9_$.
+%Tchar inext[] = {
+%F	%s,
+%p
+%T};
+%
+%	ISDIG
+%
+%C
+1:0-9
+%Tchar isdig[] = {
+%p
+%T};
+%
+%	ISHEX
+%
+%C
+1:A-F0-9
+%Tchar ishex[] = {
+%p
+%T};
+%
+%	ISOCT
+%
+%C
+1:0-7
+%Tchar isoct[] = {
+%p
+%T};
+%
+%	ISTOKEN
+%
+%C
+1:-abcefiprstuvxAEFGLMPQSTVX,;:+=()*
+%T char istoken[] = {
+%p
+%T};

util/grind/char_tools.amk

@@ -0,0 +1,24 @@
+# tabgen: tool definition for character table generator
+# variables:	TABGEN, CHTAB
+
+%include ack-defs.amk;
+
+%if (%not defined(TABGEN), {
+    TABGEN = $EMHOME/bin/tabgen;
+});
+
+%if (%not defined(CHTAB), {
+    CHTAB = chtab.c;
+});
+
+%instance deftypesuffix(char_tab, '%.ct');
+
+%tool gen_tab (
+    chtab:	%in [type = char_tab];
+    cfile:	%out [type = C-src]	=> $CHTAB;
+    mktab:	%in [type = command]	=> $TABGEN;
+)
+{
+    exec($mktab, args => '-f' $chtab, stdout => $cfile);
+    echo({$cfile, 'created'});
+};

util/grind/class.h

@@ -0,0 +1,48 @@
+/*
+ * (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ * See the copyright notice in the ACK home directory, in the file "Copyright".
+ *
+ * Author: Ceriel J.H. Jacobs
+ */
+
+/* U S E   O F   C H A R A C T E R   C L A S S E S */
+
+/* $Header$ */
+
+/*	As a starter, chars are divided into classes, according to which
+	token they can be the start of.
+	At present such a class number is supposed to fit in 4 bits.
+*/
+
+#define	class(ch)	(tkclass[ch])
+
+/*	Being the start of a token is, fortunately, a mutual exclusive
+	property, so, as there are less than 16 classes they can be
+	packed in 4 bits.
+*/
+
+#define	STSKIP	0	/* spaces and so on: skipped characters		*/
+#define	STNL	1	/* newline character(s): update linenumber etc.	*/
+#define	STGARB	2	/* garbage ascii character: not allowed		*/
+#define	STDOT	3	/* '.' can start a number, or be a separate token */
+#define	STCOMP	4	/* this one can start a compound token		*/
+#define	STIDF	5	/* being the initial character of an identifier	*/
+#define	STCHAR	6	/* the starter of a character constant		*/
+#define	STSTR	7	/* the starter of a string			*/
+#define	STNUM	8	/* the starter of a numeric constant		*/
+#define	STEOI	9	/* End-Of-Information mark			*/
+#define STSIMP  10      /* this character can occur as token            */
+
+/*	But occurring inside a token is not, so we need 1 bit for each
+	class.  This is implemented as a collection of tables to speed up
+	the decision whether a character has a special meaning.
+*/
+#define	in_idf(ch)	((unsigned)ch < 0177 && inidf[ch])
+#define	in_ext(ch)	((unsigned)ch < 0177 && inext[ch])
+#define	is_oct(ch)	((unsigned)ch < 0177 && isoct[ch])
+#define	is_dig(ch)	((unsigned)ch < 0177 && isdig[ch])
+#define	is_hex(ch)	((unsigned)ch < 0177 && ishex[ch])
+#define	is_token(ch)	((unsigned)ch < 0177 && istoken[ch])
+
+extern char tkclass[];
+extern char inidf[], isoct[], isdig[], ishex[], inext[], istoken[];

util/grind/commands.g

@@ -0,0 +1,590 @@
+/* $Header$ */
+
+/* Command grammar */
+{
+#include	<stdio.h>
+#include	<alloc.h>
+#include	<setjmp.h>
+#include	<signal.h>
+
+#include	"ops.h"
+#include	"class.h"
+#include	"position.h"
+#include	"file.h"
+#include	"idf.h"
+#include	"symbol.h"
+#include	"tree.h"
+
+extern char	*Salloc();
+extern t_lineno	currline;
+extern FILE	*db_in;
+
+int		errorgiven;
+int		extended_charset = 0;
+jmp_buf		jmpbuf;
+
+static int	init_del();
+static int	skip_to_eol();
+
+static struct token {
+  int	tokno;
+  long	ival;
+  char	*str;
+  double fval;
+  struct idf *idf;
+} tok, aside;
+
+#define TOK	tok.tokno
+#define ASIDE	aside.tokno
+}
+%start Commands, commands;
+
+%lexical LLlex;
+
+commands
+  { p_tree com, lastcom = 0;
+  }
+:
+			{ if (! setjmp(jmpbuf)) {
+				init_del();
+			  }
+			  else {
+				skip_to_eol();
+				goto prmpt;
+			  }
+			}
+  [ %persistent command_line(&com)
+			{ if (com) {
+				if (errorgiven) {
+					freenode(com);
+					com = 0;
+				}
+				if (lastcom && !in_status(lastcom) &&
+				    lastcom != run_command) {
+					freenode(lastcom);
+					lastcom = 0;
+				}
+
+				if (com) {
+			  		if (repeatable(com)) {
+						lastcom = com;
+					}
+					eval(com);
+					if (! repeatable(com) &&
+					    ! in_status(com) &&
+					    com != run_command) {
+						freenode(com);
+					}
+				}
+			  } else if (lastcom && ! errorgiven) eval(lastcom);
+			}
+    [	'\n' 		{ prmpt: prompt(); }
+    |	';'
+    ]			{ errorgiven = 0; }
+  ]*
+			{ signal_child(SIGKILL); }
+;
+
+command_line(p_tree *p;)
+:
+  list_command(p)
+| file_command(p)
+| run_command(p)
+| stop_command(p)
+| when_command(p)
+| continue_command(p)
+| step_command(p)
+| next_command(p)
+| regs_command(p)
+| WHERE			{ *p = mknode(OP_WHERE); }
+| STATUS		{ *p = mknode(OP_STATUS); }
+| DUMP			{ *p = mknode(OP_DUMP); }
+| RESTORE INTEGER	{ *p = mknode(OP_RESTORE, tok.ival); }
+| delete_command(p)
+| print_command(p)
+| trace_command(p)
+|			{ *p = 0; }
+;
+
+list_command(p_tree *p;)
+  { p_tree t1 = 0, t2 = 0; }
+:
+  LIST
+  [
+  | lin_num(&t1)
+    [ ',' lin_num(&t2)
+    |			{ t2 = mknode(OP_INTEGER, t1->t_ival); }
+    ]
+  ]			{ *p = mknode(OP_LIST, t1, t2); }
+;
+
+file_command(p_tree *p;)
+:
+  XFILE			{ extended_charset = 1; }
+  [			{ *p = 0; }
+  | name(p)		{ (*p)->t_idf = str2idf((*p)->t_str, 0); }
+  ]			{ *p = mknode(OP_FILE, *p);
+			  extended_charset = 0;
+			}
+;
+
+run_command(p_tree *p;)
+:
+  RUN			{ extended_charset = 1; *p = 0; }
+  args(p)		{ *p = mknode(OP_RUN, *p);
+			  extended_charset = 0;
+			  freenode(run_command);
+			  run_command = *p;
+			}
+| RERUN			{ if (! run_command) {
+				error("no run command given yet");
+			  }
+			  else *p = run_command;
+			}
+;
+
+stop_command(p_tree *p;)
+  { p_tree whr = 0, cond = 0; }
+:
+  STOP
+  where(&whr)?
+  condition(&cond)?	{ if (! whr && ! cond) {
+				error("no position or condition");
+				*p = 0;
+			  }
+			  else *p = mknode(OP_STOP, whr, cond);
+			}
+;
+
+trace_command(p_tree *p;)
+  { p_tree whr = 0, cond = 0, exp = 0; }
+:
+  TRACE
+  [ ON expression(&exp) ]?
+  where(&whr)?
+  condition(&cond)?	{ *p = mknode(OP_TRACE, whr, cond, exp); }
+;
+
+continue_command(p_tree *p;)
+  { long l; p_tree pos = 0; }
+:
+  CONT
+  [ INTEGER		{ l = tok.ival; }
+  |			{ l = 1; }
+  ]
+  position(&pos)?
+  			{ *p = mknode(OP_CONT, mknode(OP_INTEGER, l), pos); }
+;
+
+when_command(p_tree *p;)
+  { p_tree	whr = 0, cond = 0; }
+:
+  WHEN
+  where(&whr)?
+  condition(&cond)?
+  '{' 
+  command_line(p)
+  [ ';'			{ *p = mknode(OP_LINK, *p, (p_tree) 0);
+			  p = &((*p)->t_args[1]);
+			}
+    command_line(p)
+  ]*
+  '}'
+			{ if (! whr && ! cond) {
+				error("no position or condition");
+				freenode(*p);
+				*p = 0;
+			  }
+			  else *p = mknode(OP_WHEN, whr, cond, *p);
+			}
+;
+
+step_command(p_tree *p;)
+  { long	l; }
+:
+  STEP
+  [ INTEGER		{ l = tok.ival; }
+  |			{ l = 1; }
+  ]			{ *p = mknode(OP_STEP, l); }
+;
+
+next_command(p_tree *p;)
+  { long	l; }
+:
+  NEXT
+  [ INTEGER		{ l = tok.ival; }
+  |			{ l = 1; }
+  ]			{ *p = mknode(OP_NEXT, l); }
+;
+
+regs_command(p_tree *p;)
+  { long	l; }
+:
+  REGS
+  [ INTEGER		{ l = tok.ival; }
+  |			{ l = 0; }
+  ]			{ *p = mknode(OP_REGS, l); }
+;
+
+delete_command(p_tree *p;)
+:
+  DELETE
+  INTEGER		{ *p = mknode(OP_DELETE, tok.ival); }
+;
+
+print_command(p_tree *p;)
+:
+  PRINT expression(p)	{ *p = mknode(OP_PRINT, *p); 
+			  p = &((*p)->t_args[0]);
+			}
+  [ ','			{ *p = mknode(OP_LINK, *p, (p_tree) 0);
+			  p = &((*p)->t_args[1]);
+			}
+    expression(p)
+  ]*
+;
+
+condition(p_tree *p;)
+:
+  IF expression(p)
+;
+
+where(p_tree *p;)
+:
+  IN qualified_name(p)	{ *p = mknode(OP_IN, *p); }
+|
+  position(p)
+;
+
+expression(p_tree *p;)
+:
+	qualified_name(p)
+;
+
+position(p_tree *p;)
+  { p_tree lin;
+    char *str;
+  }
+:
+  AT
+  [ STRING		{ str = tok.str; }
+    ':'
+  |			{ if (! currfile) str = 0;
+			  else str = currfile->sy_idf->id_text;
+			}
+  ]
+  lin_num(&lin)		{ *p = mknode(OP_AT, lin->t_ival, str);
+			  freenode(lin);
+			}
+;
+
+args(p_tree *p;)
+  { int first_time = 1; }
+:
+  [			{ if (! first_time) {
+				*p = mknode(OP_LINK, *p, (p_tree) 0);
+				p = &((*p)->t_args[1]);
+			  }
+			  first_time = 0;
+			}
+	arg(p)
+  ]*
+;
+
+arg(p_tree *p;)
+:
+  name(p)
+|
+  '>' name(p)		{ (*p)->t_oper = OP_OUTPUT; }
+|
+  '<' name(p)		{ (*p)->t_oper = OP_INPUT; }
+;
+
+lin_num(p_tree *p;)
+:
+  INTEGER		{ *p = mknode(OP_INTEGER, tok.ival); }
+;
+
+qualified_name(p_tree *p;)
+:
+  name(p)
+  [	'`'		{ *p = mknode(OP_SELECT, *p, (p_tree) 0); }
+	name(&((*p)->t_args[1]))
+  ]*
+;
+
+name(p_tree *p;)
+:
+  [ XFILE
+  | LIST
+  | RUN
+  | RERUN
+  | STOP
+  | WHEN
+  | AT
+  | IN
+  | IF
+  | NAME
+  | CONT
+  | STEP
+  | NEXT
+  | REGS
+  | WHERE
+  | STATUS
+  | PRINT
+  | DELETE
+  | DUMP
+  | RESTORE
+  | TRACE
+  | ON
+  ]			{ *p = mknode(OP_NAME, tok.idf, tok.str); }
+;
+
+{
+int
+LLlex()
+{
+  register int c;
+
+  if (ASIDE) {
+	tok = aside;
+	ASIDE = 0;
+	return TOK;
+  }
+  do {
+	c = getc(db_in);
+  } while (c != EOF && class(c) == STSKIP);
+  if (c == EOF) return c;
+  switch(class(c)) {
+  case STSTR:
+	TOK = get_string(c);
+	break;
+  case STIDF:
+	TOK = get_name(c);
+	break;
+  case STDOT:
+	c = getc(db_in);
+	if (c == EOF || class(c) != STNUM) {
+		ungetc(c,db_in);
+		TOK = '.';
+		break;
+	}
+	/* Fall through */
+  case STNUM:
+	TOK = get_number(c);
+	break;
+  case STNL:
+  case STSIMP:
+	TOK = c;
+	break;
+  default:
+	error("illegal character '\\0%o'", c);
+	return LLlex();
+  }
+  return TOK;
+}
+
+int
+get_name(c)
+  register int	c;
+{
+  char	buf[512+1];
+  register char	*p = &buf[0];
+  register struct idf *id;
+
+  do {
+	if (p - buf < 512) *p++ = c;
+	c = getc(db_in);
+  } while ((extended_charset && in_ext(c)) || in_idf(c));
+  ungetc(c, db_in);
+  *p = 0;
+  if (extended_charset) {
+	tok.idf = 0;
+	tok.str = Salloc(buf, (unsigned) (p - buf));
+	return NAME;
+  }
+  id = str2idf(buf, 1);
+  tok.idf = id;
+  tok.str = id->id_text;
+  return id->id_reserved ? id->id_reserved : NAME;
+}
+
+static int
+quoted(ch)
+  int	ch;
+{
+  /*	quoted() replaces an escaped character sequence by the
+	character meant.
+  */
+  /* first char after backslash already in ch */
+  if (!is_oct(ch)) {		/* a quoted char */
+	switch (ch) {
+	case 'n':
+		ch = '\n';
+		break;
+	case 't':
+		ch = '\t';
+		break;
+	case 'b':
+		ch = '\b';
+		break;
+	case 'r':
+		ch = '\r';
+		break;
+	case 'f':
+		ch = '\f';
+		break;
+	}
+  }
+  else {				/* a quoted octal */
+	register int oct = 0, cnt = 0;
+
+	do {
+		oct = oct*8 + (ch-'0');
+		ch = getc(db_in);
+	} while (is_oct(ch) && ++cnt < 3);
+	ungetc(ch, db_in);
+	ch = oct;
+  }
+  return ch&0377;
+
+}
+
+int get_string(c)
+  int	c;
+{
+  register int ch;
+  char buf[512];
+  register int len = 0;
+
+  while (ch = getc(db_in), ch != c) {
+	if (ch == '\n') {
+		error("newline in string");
+		break;
+	}
+	if (ch == '\\') {
+		ch = getc(db_in);
+		ch = quoted(ch);
+	}
+	buf[len++] = ch;
+  }
+  buf[len++] = 0;
+  tok.str = Salloc(buf, (unsigned) len);
+  return STRING;
+}
+
+static int
+val_in_base(c, base)
+  register int c;
+{
+  return is_dig(c) 
+	? c - '0'
+	: base != 16
+	  ? -1
+	  : is_hex(c)
+	    ? (c - 'a' + 10) & 017
+	    : -1;
+}
+
+int
+get_number(c)
+  register int	c;
+{
+  char buf[512+1];
+  register int base = 10;
+  register char *p = &buf[0];
+  register long val = 0;
+  register int val_c;
+
+  if (c == '0') {
+	/* check if next char is an 'x' or an 'X' */
+	c = getc(db_in);
+	if (c == 'x' || c == 'X') {
+		base = 16;
+		c = getc(db_in);
+	}
+	else	base = 8;
+  }
+  while (val_c = val_in_base(c, base), val_c >= 0) {
+	val = val * base + val_c;
+	if (p - buf < 512) *p++ = c;
+	c = getc(db_in);
+  }
+  if (base == 16 || !((c == '.' || c == 'e' || c == 'E'))) {
+	ungetc(c, db_in);
+	tok.ival = val;
+	return INTEGER;
+  }
+  if (c == '.') {
+	if (p - buf < 512) *p++ = c;
+	c = getc(db_in);
+  }
+  while (is_dig(c)) {
+	if (p - buf < 512) *p++ = c;
+	c = getc(db_in);
+  }
+  if (c == 'e' || c == 'E') {
+	if (p - buf < 512) *p++ = c;
+	c = getc(db_in);
+	if (c == '+' || c == '-') {
+		if (p - buf < 512) *p++ = c;
+		c = getc(db_in);
+	}
+	if (! is_dig(c)) {
+		error("malformed floating constant");
+	}
+	while (is_dig(c)) {
+		if (p - buf < 512) *p++ = c;
+		c = getc(db_in);
+	}
+  }
+  ungetc(c, db_in);
+  *p++ = 0;
+  if (p == &buf[512+1]) {
+	error("floating point constant too long");
+  }
+  return REAL;
+}
+
+extern char * symbol2str();
+
+LLmessage(t)
+{
+  if (t > 0) {
+  	if (! errorgiven) {
+		error("%s missing before %s", symbol2str(t), symbol2str(TOK));
+	}
+	aside = tok;
+  }
+  else if (t == 0) {
+  	if (! errorgiven) {
+		error("%s unexpected", symbol2str(TOK));
+	}
+  }
+  else if (! errorgiven) {
+	error("EOF expected");
+  }
+  errorgiven = 1;
+}
+
+static int
+catch_del()
+{
+  signal(SIGINT, catch_del);
+  signal_child(SIGEMT);
+  longjmp(jmpbuf, 1);
+}
+
+static int
+init_del()
+{
+  signal(SIGINT, catch_del);
+}
+
+static int
+skip_to_eol()
+{
+  while (TOK != '\n' && TOK > 0) LLlex();
+  wait_for_child("interrupted");
+}
+}

util/grind/dbx_string.g

@@ -0,0 +1,679 @@
+/* $Header$
+   Grammar of a string of a debugger symbol table entry.
+*/
+
+{
+#include	<out.h>
+#include	<alloc.h>
+
+#include	"type.h"
+#include	"symbol.h"
+#include	"scope.h"
+#include	"class.h"
+#include	"idf.h"
+
+extern char	*strindex();
+extern long	str2long();
+extern double	atof();
+extern int	saw_code;
+extern long	pointer_size;
+
+static char	*DbxPtr;		/* current pointer in DBX string */
+static int	AllowName;		/* set if NAME legal at this point */
+static long	ival;
+static double	fval;
+static char	*strval;
+static int	last_index[2];
+static struct outname	*currnam;
+
+static struct literal *get_literal_space();
+static struct fields *get_field_space();
+static end_field();
+static char *string_val();
+}
+
+%start DbxParser, debugger_string;
+
+%prefix DBS;
+
+%lexical DBSlex;
+
+%onerror DBSonerror;
+
+%token	INTEGER, REAL, STRING, NAME;
+
+debugger_string
+  { register p_symbol s;
+    char *str;
+    p_type tmp = 0;
+  }
+:
+  name(&str)
+  [ /* constant name */
+			{ s = NewSymbol(str, CurrentScope, CONST, currnam); }
+	'c' const_name(s)
+
+  | /* type name */
+			{ s = NewSymbol(str, CurrentScope, TYPE, currnam); }
+	't' type_name(&(s->sy_type))
+
+  | /* tag name (only C?) */
+			{ s = NewSymbol(str, CurrentScope, TAG, currnam); }
+	'T' tag_name(s)
+
+  | /* end scope */
+	'E' INTEGER
+			{ close_scope(); }
+
+  | /* module begin */
+			{ s = NewSymbol(str, CurrentScope, MODULE, currnam); }
+	'M' INTEGER
+			{ open_scope(s, 1);
+			  s->sy_name.nm_scope = CurrentScope;
+			  CurrentScope->sc_start = currnam->on_valu;
+			  CurrentScope->sc_proclevel = currnam->on_desc;
+			  add_scope_addr(CurrentScope);
+			}
+
+  | /* external procedure */
+			{ s = NewSymbol(str, PervasiveScope, PROC, currnam); }
+	'P' routine(s)
+
+  | /* private procedure */
+			{ s = NewSymbol(str, CurrentScope, PROC, currnam); }
+	'Q' routine(s)
+
+  | /* external function */
+			{ s = NewSymbol(str, PervasiveScope, FUNCTION, currnam); }
+	'F' function(s)
+
+  | /* private function */
+			{ s = NewSymbol(str, CurrentScope, FUNCTION, currnam); }
+	'f' function(s)
+
+  | /* global variable, external */
+				/* maybe we already know it; but we need
+				   the type information anyway for other
+				   types.
+				*/
+			{ s = Lookup(findidf(str), PervasiveScope, VAR);
+			  if (s) {
+				tmp = s->sy_type;
+			  } else s = NewSymbol(str, PervasiveScope, VAR, currnam);
+			}
+	'G' type(&(s->sy_type), (int *) 0)
+			{ if (tmp) s->sy_type = tmp; } 
+
+  | /* static variable */
+			{ s = NewSymbol(str, CurrentScope, VAR, currnam); }
+	'S' type(&(s->sy_type), (int *) 0)
+
+  | /* static variable, local scope */
+			{ s = NewSymbol(str, CurrentScope, VAR, currnam); }
+	'V' type(&(s->sy_type), (int *) 0)
+
+  | /* register variable */
+			{ s = NewSymbol(str, CurrentScope, REGVAR, currnam); }
+	'r' type(&(s->sy_type), (int *) 0)
+
+  | /* value parameter */
+			{ s = NewSymbol(str, CurrentScope, LOCVAR, currnam); }
+	'p' type(&(s->sy_type), (int *) 0)
+			{ add_param_type('p', s); }
+
+  | /* value parameter but address passed */
+			{ s = NewSymbol(str, CurrentScope, VARPAR, currnam); }
+	'i' type(&(s->sy_type), (int *) 0)
+			{ add_param_type('i', s); }
+
+  | /* variable parameter */
+			{ s = NewSymbol(str, CurrentScope, VARPAR, currnam); }
+	'v' type(&(s->sy_type), (int *) 0)
+			{ add_param_type('v', s); }
+
+  | /* local variable */
+			{ s = NewSymbol(str, CurrentScope, LOCVAR, currnam); }
+	type_name(&(s->sy_type))
+
+  | /* function result in Pascal; ignore ??? */
+			{ s = NewSymbol(str, CurrentScope, LOCVAR, currnam); }
+	'X' type_name(&(s->sy_type))
+  ]
+  ';'?
+;
+
+name(char **s;)
+:
+  /* anything up to a ':' */
+  NAME	{ *s = strval; }
+;
+
+const_name(p_symbol cst;)
+  { int type_index[2];
+    long iconst;
+    register char *p;
+  }
+:
+  '='
+  [
+	'b' integer_const(&(cst->sy_const.co_ival))	/* boolean */
+  |
+	'c' integer_const(&(cst->sy_const.co_ival))	/* character */
+				{ cst->sy_type = char_type; }
+  |
+	'i' integer_const(&(cst->sy_const.co_ival))	/* integer */
+				{ cst->sy_type = long_type; }
+  |
+  	'r' real_const(&(cst->sy_const.co_rval))	/* real */
+				{ cst->sy_type = double_type; }
+  |
+	's' string_const				/* string */
+				{ cst->sy_const.co_sval = string_val(strval);
+				  cst->sy_type = string_type;
+				}
+  |
+	'e' type_index(type_index) ',' integer_const(&(cst->sy_const.co_ival))
+				/* enumeration constant;
+				 * enumeration type, value
+				 */
+				{ cst->sy_type = *tp_lookup(type_index); }
+				
+  |
+	'S' type_index(type_index)
+				{ cst->sy_type = *tp_lookup(type_index);
+				  cst->sy_const.co_setval = p =
+				    Malloc((unsigned) cst->sy_type->ty_size);
+				}
+	[ ',' integer_const(&iconst)
+				{ *p++ = iconst; }
+	]+
+				/* set constant:
+				 *  settype, values of the bytes
+				 *  in the set.
+				 */
+  ]
+;
+
+integer_const(long *iconst;)
+  { int sign = 0; }
+:
+  [ '+' | '-' { sign = 1; } ]?
+  INTEGER			{ *iconst = sign ? -ival : ival; }
+;
+
+real_const(double *f;)
+  { int sign = 0; }
+:
+  [ '+' | '-' { sign = 1; } ]?
+  REAL				{ *f = sign ? fval : -fval; }
+;
+
+string_const
+:
+  STRING			/* has SINGLE quotes! */
+;
+
+type_name(p_type *t;)
+  { int type_index[2]; p_type *p; }
+:
+  type_index(type_index)
+  [
+	'='			
+	type(t, type_index)
+				{ p = tp_lookup(type_index);
+				  if (*p && *p != incomplete_type) {
+					if (!((*p)->ty_flags & T_CROSS))
+						error("Redefining (%d,%d) %d",
+						  type_index[0],
+						  type_index[1],
+						  (*p)->ty_class);
+					if (*t && *p != *t) free_type(*p);
+				  }
+				  if (*t) *p = *t; 
+				}
+  |
+				{ p = tp_lookup(type_index); }
+  ]
+				{ if (*p == 0) *p = incomplete_type;
+				  *t = *p;
+				}
+;
+
+type_index(int *type_index;)
+:
+[
+  INTEGER			{ type_index[0] = 0; type_index[1] = ival; }
+|
+  '(' INTEGER			{ type_index[0] = ival; }
+  ',' INTEGER			{ type_index[1] = ival; }
+  ')'
+]
+				{ last_index[0] = type_index[0];
+				  last_index[1] = type_index[1];
+				}
+;
+
+tag_name(p_symbol t;)
+  { int type_index[2]; p_type *p; }
+:
+  type_index(type_index)
+  '='				
+  type(&(t->sy_type), type_index)
+				{ p = tp_lookup(type_index);
+				  if (*p && *p != incomplete_type) {
+					if (!((*p)->ty_flags & T_CROSS))
+						error("Redefining (%d,%d) %d",
+						  type_index[0],
+						  type_index[1],
+						  (*p)->ty_class);
+					if (t->sy_type && *p != t->sy_type) {
+						free_type(*p);
+					}
+				  }
+				  if (t->sy_type) *p = t->sy_type; 
+				  if (*p == 0) *p = incomplete_type;
+				}
+;
+
+function(p_symbol p;)
+:
+  			{ p->sy_type = new_type();
+			  p->sy_type->ty_class = T_PROCEDURE;
+			  p->sy_type->ty_size = pointer_size;
+			}
+  type(&(p->sy_type->ty_retval), (int *) 0) 
+  			{ if (CurrentScope != FileScope &&
+			      saw_code) {
+				/* if saw_code is not set, it is a nested
+				   procedure
+				*/
+				close_scope();
+			  }
+			  saw_code = 0;
+			  open_scope(p, 1);
+			  p->sy_name.nm_scope = CurrentScope;
+			  CurrentScope->sc_start = currnam->on_valu;
+			  add_scope_addr(CurrentScope);
+			  CurrentScope->sc_proclevel = currnam->on_desc;
+			}
+;
+
+routine(p_symbol p;)
+:
+  			{ p->sy_type = new_type();
+			  p->sy_type->ty_class = T_PROCEDURE;
+			  p->sy_type->ty_size = pointer_size;
+			  if (CurrentScope != FileScope &&
+			      saw_code) {
+				/* if saw_code is not set, it is a nested
+				   procedure
+				*/
+				close_scope();
+			  }
+			  saw_code = 0;
+			  open_scope(p, 1);
+			  p->sy_name.nm_scope = CurrentScope;
+			  CurrentScope->sc_start = currnam->on_valu;
+			  add_scope_addr(CurrentScope);
+			  CurrentScope->sc_proclevel = currnam->on_desc;
+			}
+  INTEGER ';'
+  type(&(p->sy_type->ty_retval), (int *) 0) 
+;
+
+type(p_type *ptp; int *type_index;)
+  { register p_type tp = 0;
+    p_type t1, t2;
+    long ic1, ic2;
+    int A_used = 0;
+  }
+:			{ *ptp = 0; }
+  [
+	/* type cross reference */
+	/* these are used in C for references to a struct, union or
+	 * enum that has not been declared (yet)
+	 */
+  	'x'		{ tp = new_type(); tp->ty_flags = T_CROSS; }
+  	[ 's'	/* struct */
+			{ tp->ty_class = T_STRUCT; }
+  	| 'u'	/* union */
+			{ tp->ty_class = T_UNION; }
+  	| 'e'	/* enum */
+			{ tp->ty_class = T_ENUM; }
+  	]
+			{ AllowName = 1; }
+  	name(&(tp->ty_tag))
+  |
+  	/* subrange */
+  	/* the integer_const's represent the lower and the upper bound.
+   	 * A subrange type defined as subrange of itself is an integer type.
+   	 * If the second integer_const == 0, but the first is not, we
+   	 * have a floating point type with size equal to the first
+   	 * integer_const.
+   	 * Upperbound -1 means unsigned int or unsigned long.
+   	 */
+  	'r' type_name(&t1) ';'
+	[ 'A' integer_const(&ic1)	{ A_used = 1; }
+	| integer_const(&ic1)
+	]
+	';'
+	[ 'A' integer_const(&ic2)	{ A_used |= 2; }
+	| integer_const(&ic2)
+	]
+			{ *ptp = subrange_type(A_used,
+					       last_index,
+					       ic1,
+					       ic2,
+					       type_index);
+			}
+  |
+  	/* array; first type is bound type, next type
+   	 * is element type
+   	 */
+  	'a' type(&t1, (int *) 0) ';' type(&t2, (int *) 0)
+			{ *ptp = array_type(t1, t2); }
+  |
+  	/* structure type */
+  	's'		{ tp = new_type(); tp->ty_class = T_STRUCT; }
+	structure_type(tp)
+  |
+  	/* union type */
+  	'u'		{ tp = new_type(); tp->ty_class = T_UNION; }
+	structure_type(tp)
+  |
+  	/* enumeration type */
+  	'e'		{ tp = new_type(); tp->ty_class = T_ENUM; }
+	enum_type(tp)
+  |
+  	/* pointer type */
+  	'*'		{ tp = new_type(); tp->ty_class =T_POINTER;
+			  tp->ty_size = pointer_size;
+			}
+  	type(&(tp->ty_ptrto), (int *) 0)
+  |
+  	/* function type */
+  	'f'		{ tp = new_type(); tp->ty_class = T_PROCEDURE;
+			  tp->ty_size = pointer_size;
+			}
+  	type(&(tp->ty_retval), (int *) 0) 
+/*
+  	[ %prefer
+		',' param_list(tp)
+  	|
+  	]
+*/
+  |
+  	/* procedure type */
+  	'Q'		{ tp = new_type(); tp->ty_class = T_PROCEDURE;
+			  tp->ty_size = pointer_size;
+			}
+  	type(&(tp->ty_retval), (int *) 0) 
+	',' param_list(tp)
+  |
+  	/* another procedure type */
+  	'p'		{ tp = new_type(); tp->ty_class = T_PROCEDURE;
+			  tp->ty_size = pointer_size;
+			  tp->ty_retval = void_type;
+			}
+	param_list(tp)
+  |
+  	/* set type */
+  	/* the first integer_const represents the size in bytes,
+   	 * the second one represents the low bound
+   	 */
+  	'S'		{ tp = new_type(); tp->ty_class = T_SET; }
+	type(&(tp->ty_setbase), (int *) 0) ';'
+	[
+		integer_const(&(tp->ty_size)) ';'
+		integer_const(&(tp->ty_setlow)) ';'
+	|
+			{ set_bounds(tp); }
+	]
+  |
+	/* file type of Pascal */
+	'L'		{ tp = new_type(); tp->ty_class = T_FILE; }
+	type(&(tp->ty_fileof), (int *) 0)
+  |
+  	type_name(ptp)
+			{ if (type_index &&
+			      *ptp == incomplete_type &&
+			      type_index[0] == last_index[0] &&
+			      type_index[1] == last_index[1]) {
+				*ptp = void_type;
+			  }
+			}
+  ]
+			{ if (! *ptp) *ptp = tp; }
+;
+
+structure_type(register p_type tp;)
+  { register struct fields *fldp; }
+:
+  integer_const(&(tp->ty_size))		/* size in bytes */
+  [			{ fldp = get_field_space(tp); }
+	name(&(fldp->fld_name))
+	type(&(fldp->fld_type), (int *) 0) ','
+	integer_const(&(fldp->fld_pos)) ','	/* offset in bits */
+	integer_const(&(fldp->fld_bitsize)) ';'	/* size in bits */
+  ]*
+  ';'			{ end_field(tp); }
+;
+
+enum_type(register p_type tp;)
+  { register struct literal *litp;
+    long maxval = 0;
+  }
+:
+  [			{ litp = get_literal_space(tp);
+			}
+	name(&(litp->lit_name))
+	integer_const(&(litp->lit_val)) ',' 
+			{ if (maxval < litp->lit_val) maxval = litp->lit_val;
+			  AllowName = 1;
+			}
+  ]*
+  ';'			{ end_literal(tp, maxval); }
+;
+
+param_list(p_type t;)
+  { register struct param *p;
+    long iconst;
+  }
+:
+  integer_const(&iconst) ';'	/* number of parameters */
+			{ t->ty_nparams = iconst;
+			  t->ty_params = p = (struct param *)
+			    Malloc((unsigned)(t->ty_nparams * sizeof(struct param)));
+			}
+  [
+  	[	'p'	{ p->par_kind = 'p'; }
+  	|	'v'	{ p->par_kind = 'v'; }
+  	|	'i' 	{ p->par_kind = 'i'; }
+  	]
+  	type(&(p->par_type), (int *) 0) ';'
+			{ t->ty_nbparams += 
+				param_size(p->par_type, p->par_kind);
+			  p++;
+			}
+  ]*
+;
+
+{
+static char *dbx_string;
+static char *DbxOldPtr;
+
+struct outname *
+DbxString(n)
+  struct outname	*n;
+{
+  currnam = n;
+  DbxPtr = n->on_mptr;
+  dbx_string = DbxPtr;
+  AllowName = 1;
+  DbxParser();
+  return currnam;
+}
+
+/*ARGSUSED*/
+DBSmessage(n)
+{
+  fatal("error in Dbx string \"%s\", DbxPtr = \"%s\", DbxOldPtr = \"%s\"",
+	dbx_string,
+	DbxPtr,
+	DbxOldPtr);
+
+}
+
+DBSonerror(tk, p)
+  int	*p;
+{
+  DbxPtr = DbxOldPtr;
+/* ???  if (DBSsymb < 0) {
+	while (*p && *p != ';') p++;
+	if (*p) DbxPtr = ";";
+	return;
+  }
+*/
+  if (! tk) {
+	while (*p && *p != NAME) p++;
+	if (*p) {
+		AllowName = 1;
+	}
+  }
+  else if (tk == NAME) AllowName = 1;
+}
+
+DBSlex()
+{
+  register char *cp = DbxPtr;
+  int allow_name = AllowName;
+  register int c;
+
+  AllowName = 0;
+  DbxOldPtr = cp;
+  c = *cp;
+  if (c == '\\' && *(cp+1) == '\0') {
+	currnam++;
+	cp = currnam->on_mptr;
+	DbxOldPtr = cp;
+	c = *cp;
+  }
+  if (! c) {
+	DbxPtr = cp;
+	return -1;
+  }
+  if ((! allow_name && is_token(c)) || c == ';') {
+	DbxPtr = cp+1;
+	return c;
+  }
+  if (is_dig(c)) {
+	int retval = INTEGER;
+
+	while (++cp, is_dig(*cp)) /* nothing */;
+	c = *cp;
+	if (c == '.') {
+		retval = REAL;
+		while (++cp, is_dig(*cp)) /* nothing */;
+		c = *cp;
+	}
+	if (c == 'e' || c == 'E') {
+		char *oldcp = cp;
+
+		cp++;
+		c = *cp;
+		if (c == '-' || c == '+') {
+			cp++;
+			c = *cp;
+		}
+		if (is_dig(c)) {
+			retval = REAL;
+			while (++cp, is_dig(*cp)) /* nothing */;
+		}
+		else cp = oldcp;
+	}
+	c = *cp;
+	*cp = 0;
+	if (retval == INTEGER) {
+		ival = str2long(DbxOldPtr, 10);
+	}
+	else {
+		fval = atof(DbxOldPtr);
+	}
+	*cp = c;
+	DbxPtr = cp;
+	return retval;
+  }
+  if (c == '\'') {
+	cp++;
+	strval = cp;
+	while ((c = *cp) && c != '\'') {
+		if (c == '\\') cp++;	/* backslash escapes next character */
+		if (!(c =  *cp)) break;	/* but not a null byte */
+		cp++;
+	}
+	if (! c) DBSmessage(0);	/* no return */
+	*cp = 0;
+	DbxPtr = cp + 1;
+	return STRING;
+  }
+  strval = cp;
+  while ((c = *cp) && c != ':' && c != ',') cp++;
+  DbxPtr = *cp ? cp+1 : cp;
+  *cp = 0;
+  return NAME;
+}
+
+static struct fields *
+get_field_space(tp)
+  register p_type tp;
+{
+  if (! (tp->ty_nfields & 07)) {
+	tp->ty_fields = (struct fields *)
+		  Realloc((char *) tp->ty_fields,
+			    (tp->ty_nfields+8)*sizeof(struct fields));
+  }
+  return &tp->ty_fields[tp->ty_nfields++];
+}
+
+static
+end_field(tp)
+  register p_type tp;
+{
+  tp->ty_fields = (struct fields *)
+	Realloc((char *) tp->ty_fields,
+		tp->ty_nfields * sizeof(struct fields));
+}
+
+static struct literal *
+get_literal_space(tp)
+  register p_type tp;
+{
+  if (! (tp->ty_nenums & 07)) {
+	tp->ty_literals = (struct literal *)
+		Realloc((char *) tp->ty_literals,
+			(tp->ty_nenums+8)*sizeof(struct literal));
+  }
+  return &tp->ty_literals[tp->ty_nenums++];
+}
+
+static char *
+string_val(s)
+  char	*s;
+{
+  register char *ns = s, *os = s;
+  register unsigned int i = 1;
+
+  for (;;) {
+	if (!*os) break;
+	i++;
+	if (*os == '\\') {
+		os++;
+		*ns++ = *os++;
+	}
+	else *ns++ = *os++;
+  }
+  *ns = '\0';
+  return Salloc(s, i);
+}
+
+}

util/grind/dbxread.c

@@ -0,0 +1,194 @@
+/* $Header$
+   Read the symbol table from an ACK a.out format file.
+*/
+
+#include <stb.h>
+#include <alloc.h>
+#include <assert.h>
+
+#include "position.h"
+#include "file.h"
+#include "symbol.h"
+#include "idf.h"
+#include "scope.h"
+#include "rd.h"
+
+extern char		*Malloc();
+extern char		*strindex();
+extern struct outname	*DbxString();
+
+int			saw_code = 0;
+
+static char		*AckStrings;	/* ACK a.out string table */
+static struct outname	*AckNames;	/* ACK a.out symbol table entries */
+static unsigned int	NAckNames;	/* Number of ACK symbol table entries */
+static struct outname	*EndAckNames;	/* &AckNames[NAckNames] */
+
+/* Read the symbol table from file 'f', which is supposed to be an
+   ACK a.out format file. Offer DBX strings to the DBX string parser.
+*/
+int
+DbxRead(f)
+  char	*f;
+{
+  struct outhead h;
+  register struct outname *n;
+  register struct outname *line_file = 0;
+  long OffsetStrings;
+  int had_lbrac = 0;
+
+  /* Open file, read header, and check magic word */
+  if (! rd_open(f)) {
+  	fatal("%s: not an ACK object file", f);
+  }
+  rd_ohead(&h);
+  if (BADMAGIC(h) && h.oh_magic != O_CONVERTED) {
+  	fatal("%s: not an ACK object file", f);
+  }
+
+  /* Allocate space for name table and read it */
+  AckNames = (struct outname *) 
+  		Malloc((unsigned)(sizeof(struct outname) * h.oh_nname));
+  AckStrings = Malloc((unsigned) h.oh_nchar);
+  rd_name(AckNames, h.oh_nname);
+  rd_string(AckStrings, h.oh_nchar);
+
+  /* Adjust file offsets in name table to point at strings */
+  OffsetStrings = OFF_CHAR(h);
+  NAckNames = h.oh_nname;
+  EndAckNames = &AckNames[h.oh_nname];
+  for (n = EndAckNames; --n >= AckNames;) {
+	if (n->on_foff) {
+		if ((unsigned)(n->on_foff - OffsetStrings) >= h.oh_nchar) {
+			fatal("%s: error in object file", f);
+		}
+		n->on_mptr = AckStrings + (n->on_foff - OffsetStrings);
+	}
+	else	n->on_mptr = 0;
+  }
+
+  /* Offer strings to the DBX string parser if they contain a ':'.
+     Also offer filename-line number information to add_position_addr().
+     Here, the order may be important.
+  */
+  for (n = &AckNames[0]; n < EndAckNames; n++) {
+	int tp = n->on_type >> 8;
+	register p_symbol sym;
+
+	if (tp & (S_STB >> 8)) {
+		switch(tp) {
+#ifdef N_BINCL
+		case N_BINCL:
+			n->on_valu = (long) line_file;
+			line_file = n;
+			break;
+		case N_EINCL:
+			if (line_file) {
+				line_file = (struct outname *) line_file->on_valu;
+			}
+			break;
+#endif
+		case N_SO:
+			if (n->on_mptr[strlen(n->on_mptr)-1] == '/') {
+				/* another N_SO follows ... */
+				break;
+			}
+			while (CurrentScope != PervasiveScope) {
+				close_scope();
+			}
+			saw_code = 0;
+			sym = add_file(n->on_mptr);
+
+			if (! currfile) newfile(sym->sy_idf);
+			open_scope(sym, 0);
+			sym->sy_file->f_scope = CurrentScope;
+			FileScope = CurrentScope;
+			clean_tp_tab();
+			/* fall through */
+		case N_SOL:
+			if (! line_file) line_file = n;
+			else line_file->on_mptr = n->on_mptr;
+			break;
+		case N_MAIN:
+			newfile(FileScope->sc_definedby->sy_idf);
+			break;
+		case N_SLINE:
+			assert(line_file);
+			if (! saw_code && !CurrentScope->sc_bp_opp) {
+			    CurrentScope->sc_bp_opp = n->on_valu;
+			    if (! CurrentScope->sc_start) {
+				CurrentScope->sc_start = n->on_valu;
+				if (CurrentScope->sc_has_activation_record) {
+					add_scope_addr(CurrentScope);
+				}
+			    }
+			}
+			saw_code = 1;
+			add_position_addr(line_file->on_mptr, n);
+			break;
+		case N_LBRAC:	/* block, desc = nesting level */
+			if (had_lbrac) {
+				open_scope((p_symbol) 0, 0);
+				saw_code = 0;
+			}
+			else {
+				register p_scope sc = 
+					get_scope_from_addr(n->on_valu);
+
+				if (!sc || sc->sc_bp_opp) {
+					had_lbrac = 1;
+				}
+				else CurrentScope = sc;
+			}
+			break;
+#ifdef N_SCOPE
+		case N_SCOPE:
+			if (n->on_mptr && strindex(n->on_mptr, ':')) {
+				n = DbxString(n);
+			}
+			break;
+#endif
+		case N_RBRAC:	/* end block, desc = nesting level */
+			had_lbrac = 0;
+			if (CurrentScope != FileScope) close_scope();
+			saw_code = 0;
+			break;
+		case N_FUN:	/* function, value = address */
+		case N_GSYM:	/* global variable */
+		case N_STSYM:	/* data, static, value = address */
+		case N_LCSYM:	/* bss, static, value = address */
+		case N_RSYM:	/* register var, value = reg number */
+		case N_SSYM:	/* struct/union el, value = offset */
+		case N_PSYM:	/* parameter, value = offset from AP */
+		case N_LSYM:	/* local sym, value = offset from FP */
+			if (had_lbrac) {
+				open_scope((p_symbol) 0, 0);
+				saw_code = 0;
+				had_lbrac = 0;
+			}
+			if (n->on_mptr && strindex(n->on_mptr, ':')) {
+				n = DbxString(n);
+			}
+			break;
+		default:
+/*
+			if (n->on_mptr && (n->on_type&S_TYP) >= S_MIN) {
+				struct idf *id = str2idf(n->on_mptr, 0);
+
+				sym = new_symbol();
+				sym->sy_next = id->id_def;
+				id->id_def = sym;
+				sym->sy_class = SYMENTRY;
+				sym->sy_onam = *n;
+				sym->sy_idf = id;
+			}
+*/
+			break;
+		}
+	}
+  }
+  close_scope();
+  add_position_addr((char *) 0, (struct outname *) 0);
+  rd_close();
+  return (h.oh_magic == O_CONVERTED);
+}

util/grind/dump.c

@@ -0,0 +1,65 @@
+/* $Header$ */
+
+#include <assert.h>
+#include <alloc.h>
+
+#include "operator.h"
+#include "position.h"
+#include "tree.h"
+#include "message.h"
+
+extern long	pointer_size;
+extern p_tree	get_from_item_list();
+
+struct dump {
+  char	*globals, *stack;
+  struct message_hdr mglobal, mstack;
+};
+
+/* dumping and restoring of child process.
+*/
+do_dump(p)
+  p_tree	p;
+{
+  struct dump *d = (struct dump *) Malloc(sizeof(struct dump));
+
+  if (! get_dump(&d->mglobal, &d->globals, &d->mstack, &d->stack)) {
+	error("no debuggee");
+	free((char *) d);
+	return;
+  }
+  p->t_args[0] = (struct tree *) d;
+  p->t_address = (t_addr) BUFTOA(d->mglobal.m_buf+PC_OFF*pointer_size);
+  add_to_item_list(p);
+}
+
+/* dumping and restoring of child process.
+*/
+do_restore(p)
+  p_tree	p;
+{
+  struct dump *d;
+  
+  p = get_from_item_list((int) p->t_ival);
+  if (!p || p->t_oper != OP_DUMP) {
+	error("no such dump");
+	return;
+  }
+
+  d = (struct dump *) p->t_args[0];
+
+  if (! put_dump(&d->mglobal, d->globals, &d->mstack, d->stack)) {
+	error("no debuggee");
+  }
+  do_items();
+}
+
+free_dump(p)
+  p_tree	p;
+{
+  struct dump *d = (struct dump *) p->t_args[0];
+
+  free(d->globals);
+  free(d->stack);
+  free((char *) d);
+}

util/grind/expr.c

@@ -0,0 +1,13 @@
+/* $Header$ */
+
+#include "position.h"
+#include "operator.h"
+#include "tree.h"
+
+int
+eval_cond(p)
+  p_tree	p;
+{
+  /* to be written !!! */
+  return 1;
+}

util/grind/file.hh

@@ -0,0 +1,38 @@
+/* $Header$ */
+
+/* Structure for information about files. This information consists of three
+   parts:
+   - file name and directory
+   - mapping of line numbers to offsets in file
+   - mapping of object adresses to lines in file and vice versa
+*/
+
+#define LOGHSIZ		6		/* make sure HSIZ is a power of 2 */
+#define HSIZ		(1 << LOGHSIZ)
+#define	HASH(line)	((line) & (HSIZ-1))
+
+typedef struct file {
+	struct symbol	*f_sym;
+	char		*f_fullname;	/* name including directory */
+	struct scope	*f_scope;	/* reference to scope of this file */
+	t_lineno	f_nlines;	/* number of lines in file */
+	union {
+	  long		*ff_linepos;	/* positions of lines in file */
+	  struct file	*ff_next;	/* only for BINCL, EINCL */
+	} f_x;
+#define f_linepos	f_x.ff_linepos
+#define f_next		f_x.ff_next
+	struct outname	*f_start;
+	struct outname	*f_end;
+	struct outname	*f_line_addr[HSIZ];
+					/* hash table, mapping line numbers to
+					   outname structures. Collisions are
+					   resolved by chaining:
+					*/
+#define next_outname(n)		((struct outname *) ((n)->on_mptr))
+#define setnext_outname(n,m)	((n)->on_mptr = (char *) (m))
+
+	struct file	*f_nextmap;	/* next file in mapping */
+} t_file, *p_file;
+
+/* ALLOCDEF "file" 10 */

util/grind/idf.c

@@ -0,0 +1,15 @@
+/*
+ * (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ * See the copyright notice in the ACK home directory, in the file "Copyright".
+ *
+ * Author: Ceriel J.H. Jacobs
+ */
+
+/* I N S T A N T I A T I O N   O F   I D F   P A C K A G E */
+
+/* $Header$ */
+
+#include	"position.h"
+#include	"file.h"
+#include	"idf.h"
+#include	<idf_pkg.body>

util/grind/idf.h

@@ -0,0 +1,21 @@
+/*
+ * (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ * See the copyright notice in the ACK home directory, in the file "Copyright".
+ *
+ * Author: Ceriel J.H. Jacobs
+ */
+
+/* U S E R   D E C L A R E D   P A R T   O F   I D F */
+
+/* $Header$ */
+
+struct id_u {
+	int id_res;
+	struct symbol *id_df;
+};
+
+#define IDF_TYPE	struct id_u
+#define id_reserved	id_user.id_res
+#define id_def		id_user.id_df
+
+#include	<idf_pkg.spec>

util/grind/itemlist.cc

@@ -0,0 +1,163 @@
+/* $Header$ */
+
+#include <alloc.h>
+#include <stdio.h>
+#include <assert.h>
+
+#include "position.h"
+#include "tree.h"
+#include "operator.h"
+
+extern FILE	*db_out;
+extern int	db_ss;
+
+typedef struct item {
+  struct item		*i_next;
+  struct tree		*i_node;
+} t_item, *p_item;
+
+/* STATICALLOCDEF "item" 10 */
+
+struct itemlist {
+  p_item	il_first, il_last;
+  int		il_count;
+};
+
+static struct itemlist	item_list;
+
+int
+in_item_list(p)
+  p_tree	p;
+{
+  register p_item i = item_list.il_first;
+
+  while (i) {
+	if (i->i_node == p) return 1;
+	i = i->i_next;
+  }
+  return 0;
+}
+
+int
+item_addr_actions(a)
+  t_addr	a;
+{
+  /* Perform actions associated with position 'a', and return 1 if we must stop
+     there, and 0 if not.
+  */
+  register p_item i = item_list.il_first;
+  int stopping = 0;
+
+  while (i) {
+	register p_tree	p = i->i_node;
+
+	if (p->t_address == a || p->t_address == NO_ADDR) {
+		switch(p->t_oper) {
+		case OP_TRACE:
+		case OP_WHEN:
+			if (! p->t_args[1] ||
+			    eval_cond(p->t_args[1])) {
+				perform(p, a);
+			}
+			break;
+		case OP_STOP:
+			if (! p->t_args[1] ||
+			    eval_cond(p->t_args[1])) stopping = 1;
+			break;
+		case OP_DUMP:
+			break;
+		default:
+			assert(0);
+		}
+	}
+	i = i->i_next;
+  }
+  return stopping;
+}
+
+add_to_item_list(p)
+  p_tree	p;
+{
+  p_item i;
+  
+  if (in_item_list(p)) return 1;
+
+  i = new_item();
+  i->i_node = p;
+  if (p->t_address == NO_ADDR &&
+      (p->t_oper != OP_TRACE || ! p->t_args[0])) db_ss++;
+  if (item_list.il_first == 0) {
+	item_list.il_first = i;
+  }
+  else {
+	item_list.il_last->i_next = i;
+  }
+  p->t_itemno = ++item_list.il_count;
+  item_list.il_last = i;
+  pr_item(p);
+  return 1;
+}
+
+p_tree
+remove_from_item_list(n)
+  int	n;
+{
+  register p_item i = item_list.il_first, prev = 0;
+  p_tree	p = 0;
+
+  while (i) {
+	if (i->i_node->t_itemno == n) break;
+	prev = i;
+	i = i->i_next;
+  }
+  if (i) {
+	if (prev) {
+		prev->i_next = i->i_next;
+	}
+	else item_list.il_first = i->i_next;
+	if (i == item_list.il_last) item_list.il_last = prev;
+	p = i->i_node;
+	if (p->t_address == NO_ADDR &&
+	    (p->t_oper != OP_TRACE || ! p->t_args[0])) db_ss--;
+	free_item(i);
+  }
+  return p;
+}
+
+p_tree
+get_from_item_list(n)
+  int	n;
+{
+  register p_item i = item_list.il_first;
+
+  while (i) {
+	if (i->i_node->t_itemno == n) return i->i_node;
+	i = i->i_next;
+  }
+  return 0;
+}
+
+print_items()
+{
+  register p_item i = item_list.il_first;
+
+  for (; i; i = i->i_next) {
+	pr_item(i->i_node);
+  }
+}
+
+pr_item(p)
+  p_tree	p;
+{
+  fprintf(db_out, "(%d)\t", p->t_itemno);
+  print_node(p, 1);
+}
+
+do_items()
+{
+  register p_item i = item_list.il_first;
+
+  for (; i; i = i->i_next) {
+	if (i->i_node->t_oper != OP_DUMP) eval(i->i_node);
+  }
+}

util/grind/langdep.cc

@@ -0,0 +1,47 @@
+/* $Header$ */
+
+#include "langdep.h"
+
+struct langlist {
+  struct langlist	*l_next;
+  struct langdep	*l_lang;
+  char			*l_suff;
+};
+
+/* STATICALLOCDEF "langlist" 5 */
+
+static struct langlist *list;
+
+struct langdep	*currlang;
+
+static int
+add_language(suff, lang)
+  char	*suff;
+  struct langdep *lang;
+{
+  struct langlist *p = new_langlist();
+
+  p->l_next = list;
+  p->l_suff = suff;
+  p->l_lang = lang;
+  list = p;
+}
+
+int
+init_languages()
+{
+  add_language(".mod", m2_dep);
+}
+
+int
+find_language(suff)
+  char	*suff;
+{
+  register struct langlist *p = list;
+
+  while (p) {
+	currlang = p->l_lang;
+	if (! strcmp(p->l_suff, suff)) break;
+	p = p->l_next;
+  }
+}

util/grind/langdep.h

@@ -0,0 +1,32 @@
+/* $Header$ */
+
+/* language-dependent routines and formats, together in one structure: */
+
+struct langdep {
+  /* formats (for fprintf): */
+  char	*decint_fmt;		/* decimal ints (format for long) */
+  char	*octint_fmt;		/* octal ints (format for long) */
+  char	*hexint_fmt;		/* hexadecimal ints (format for long) */
+  char	*uns_fmt;		/* unsigneds (format for long) */
+  char	*addr_fmt;		/* address (format for long) */
+  char	*real_fmt;		/* real (format for double) */
+  char	*char_fmt;		/* character (format for int) */
+
+  /* display openers and closers: */
+  char	*open_array_display;
+  char	*close_array_display;
+  char	*open_struct_display;
+  char	*close_struct_display;
+  char	*open_set_display;
+  char	*close_set_display;
+
+  /* language dependant routines: */
+  int	(*printstring)();
+  long	(*arrayelsize)();
+};
+
+extern struct langdep	*m2_dep, *currlang;
+
+extern int find_language();
+
+extern int init_languages();

util/grind/list.c

@@ -0,0 +1,146 @@
+/* $Header$ */
+
+#include <stdio.h>
+#include <alloc.h>
+
+#include "position.h"
+#include "idf.h"
+#include "file.h"
+#include "symbol.h"
+
+static	line_positions();
+extern char	*dirs[];
+extern FILE	*fopen();
+extern FILE	*db_out;
+#define	window_size	21
+
+static int
+mk_filnm(dir, file, newname)
+  char	*dir;
+  char	*file;
+  char	**newname;
+{
+  register char	*dst = Malloc((unsigned) (strlen(dir) + strlen(file) + 2));
+
+  *newname = dst;
+  if (*dir) {
+	while (*dst++ = *dir++) /* nothing */;
+	*(dst - 1) = '/';
+  }
+  while (*dst++ = *file++) /* nothing */;
+}
+
+static FILE *
+open_file(fn, mode, ffn)
+  char	*fn;
+  char	*mode;
+  char	**ffn;
+{
+  FILE	*f;
+  char	**p;
+
+  if (fn[0] == '/') {
+	*ffn = fn;
+	return fopen(fn, mode);
+  }
+  p = dirs;
+  while (*p) {	
+	mk_filnm(*p++, fn, ffn);
+	if ((f = fopen(*ffn, mode)) != NULL) {
+		return f;
+	}
+	free(*ffn);
+  }
+  return NULL;
+}
+
+/*	Print a window of window_size lines around line "line" of
+	file "file".
+*/
+window(file, line)
+  p_file	file;
+  int		line;
+{
+  lines(file,
+	line + ((window_size >> 1) - window_size), line + (window_size >> 1));
+}
+
+lines(file, l1, l2)
+  register p_file file;
+  int		l1, l2;
+{
+  static p_file last_file;
+  static FILE *last_f;
+  register FILE	*f;
+  register int	n;
+
+  if (last_file != file) {
+	if (last_f) fclose(last_f);
+	last_f = 0;
+  	if (!(f = open_file(file->f_sym->sy_idf->id_text, 
+			    "r",
+			    &file->f_fullname))) {
+		error("could not open %s", file->f_sym->sy_idf->id_text);
+		return;
+	}
+	printf("filedesc = %d\n", fileno(f));
+	last_file = file;
+	last_f = f;
+	if (! file->f_linepos) {
+		line_positions(file, f);
+	}
+  }
+  else f = last_f;
+
+  if (l1 < 1) l1 = 1;
+  if (l2 > file->f_nlines) l2 = file->f_nlines;
+  if (l1 > l2) {
+	error("%s has only %d lines", file->f_sym->sy_idf->id_text, file->f_nlines);
+	return;
+  }
+
+  fseek(f, *(file->f_linepos+(l1-1)), 0);
+  for (n = l1; n <= l2; n++) {
+	register int	c;
+
+	fprintf(db_out, "%6d  ", n);
+	do {
+		c = getc(f);
+		if (c != EOF) putc(c, db_out);
+	} while (c != '\n' && c != EOF);
+	if (c == EOF) break;
+  }
+  clearerr(f);
+}
+
+static
+line_positions(file, f)
+  p_file	file;
+  register FILE	*f;
+{
+  int		nl;
+  unsigned int	n_alloc = 256;
+  register long	cnt = 0;
+  register int	c;
+
+  file->f_linepos = (long *) Malloc(n_alloc * sizeof(long));
+  file->f_linepos[0] = 0;
+  nl = 1;
+  while ((c = getc(f)) != EOF) {
+	cnt++;
+	if (c == '\n') {
+		if (nl == n_alloc) {
+			n_alloc <<= 1;
+			file->f_linepos =
+				(long *) Realloc((char *)(file->f_linepos),
+						 n_alloc * sizeof(long));
+		}
+		file->f_linepos[nl++] = cnt;
+	}
+  }
+  if (cnt == file->f_linepos[nl-1]) nl--;
+  file->f_linepos = (long *) Realloc((char *)(file->f_linepos),
+					(unsigned)nl * sizeof(long));
+  file->f_nlines = nl;
+  clearerr(f);
+}

util/grind/main.c

@@ -0,0 +1,121 @@
+#include <stdio.h>
+#include <varargs.h>
+
+#include "tokenname.h"
+#include "position.h"
+#include "file.h"
+#include "symbol.h"
+#include "scope.h"
+
+static char	*usage = "Usage: %s [-d] [<ack.out>] [<a.out>]";
+static char	*progname;
+char		*AckObj;
+char		*AObj;
+char		*dirs[] = { "", 0 };
+FILE		*db_out;
+FILE		*db_in;
+t_lineno	currline;
+int		debug;
+extern struct tokenname tkidf[];
+extern char	*strindex();
+
+main(argc, argv)
+  char	*argv[];
+{
+  char	*p;
+
+  db_out = stdout;
+  db_in = stdin;
+  progname = argv[0];
+  while (p = strindex(progname, '/')) {
+	progname = p + 1;
+  }
+  if (argv[1][0] == '-') {
+	switch(argv[1][1]) {
+	case 'd':
+		debug++;
+		break;
+	default:
+		fatal(usage, progname);
+	}
+	argv++;
+	argc--;
+  }
+  if (argc > 3) {
+	fatal(usage, progname);
+  }
+  AckObj = argv[1] ? argv[1] : "a.out";
+  if (argc == 3) AObj = argv[2];
+  init_idf();
+  init_types();
+  init_scope();
+  init_languages();
+  if (DbxRead(AckObj) && AObj == 0) AObj = AckObj;
+  else if (AObj == 0) AObj = "a.out";
+  reserve(tkidf);
+  if (currfile) CurrentScope = currfile->sy_file->f_scope;
+  if (! init_run()) {
+	fatal("something wrong with file descriptors");
+  }
+  prompt();
+  Commands();
+  fputc( '\n', db_out);
+  exit(0);
+}
+
+prompt()
+{
+  if (isatty(fileno(db_in))) {
+	fprintf(db_out, "%s -> ", progname);
+	fflush(db_out);
+  }
+}
+
+/*VARARGS1*/
+fatal(va_alist)
+  va_dcl
+{
+  va_list ap;
+  char *fmt;
+
+  va_start(ap);
+  {
+	fmt = va_arg(ap, char *);
+	fprintf(stderr, "%s: ", progname);
+	vfprintf(stderr, fmt, ap);
+	fprintf(stderr, "\n");
+  }
+  va_end(ap);
+  abort();
+  exit(1);
+}
+
+extern int errorgiven;
+
+/*VARARGS1*/
+error(va_alist)
+  va_dcl
+{
+  va_list ap;
+  char *fmt;
+
+  va_start(ap);
+  {
+	fmt = va_arg(ap, char *);
+	fprintf(stderr, "%s: ", progname);
+	vfprintf(stderr, fmt, ap);
+	fprintf(stderr, "\n");
+  }
+  va_end(ap);
+  errorgiven = 1;
+}
+
+rd_fatal()
+{
+  fatal("read error in %s", AckObj);
+}
+
+No_Mem()
+{
+  fatal("out of memory");
+}

util/grind/make.allocd

@@ -0,0 +1,26 @@
+sed -e '
+s:^.*[ 	]ALLOCDEF[ 	].*"\(.*\)"[ 	]*\([0-9][0-9]*\).*$:\
+/* allocation definitions of struct \1 */\
+extern char *st_alloc();\
+extern struct \1 *h_\1;\
+#ifdef DEBUG\
+extern int cnt_\1;\
+extern char *std_alloc();\
+#define	new_\1() ((struct \1 *) std_alloc((char **)\&h_\1, sizeof(struct \1), \2, \&cnt_\1))\
+#else\
+#define	new_\1() ((struct \1 *) st_alloc((char **)\&h_\1, sizeof(struct \1), \2))\
+#endif\
+#define	free_\1(p) st_free(p, \&h_\1, sizeof(struct \1))\
+:' -e '
+s:^.*[ 	]STATICALLOCDEF[ 	].*"\(.*\)"[ 	]*\([0-9][0-9]*\).*$:\
+/* allocation definitions of struct \1 */\
+extern char *st_alloc();\
+struct \1 *h_\1;\
+#ifdef DEBUG\
+int cnt_\1;\
+#define	new_\1() ((struct \1 *) std_alloc((char **)\&h_\1, sizeof(struct \1), \2, \&cnt_\1))\
+#else\
+#define	new_\1() ((struct \1 *) st_alloc((char **)\&h_\1, sizeof(struct \1), \2))\
+#endif\
+#define	free_\1(p) st_free(p, \&h_\1, sizeof(struct \1))\
+:'

util/grind/make.next

@@ -0,0 +1,6 @@
+sed -n '
+s:^.*[ 	]ALLOCDEF[ 	].*"\(.*\)".*$:struct \1 *h_\1 = 0;\
+#ifdef DEBUG\
+int cnt_\1 = 0;\
+#endif:p
+' $*

util/grind/make.ops

@@ -0,0 +1,18 @@
+awk '
+BEGIN	{ n = 0 }
+	{ print "#define " $1 " " n; n++
+	  if ($3 !~ /0/) print "extern int " $3 "();" ;
+	}
+' < $1 > ops.h
+
+cat > ops.c <<'EOF'
+#include "operator.h"
+#include "ops.h"
+
+t_operator operators[] = {
+EOF
+awk '	{ print "{ " $2 ", " $3 "}, /* " $1 " */" }' < $1 >> ops.c
+cat >> ops.c <<'EOF'
+{ 0, 0 }
+};
+EOF

util/grind/make.tokcase

@@ -0,0 +1,36 @@
+cat <<'--EOT--'
+/* Generated by make.tokcase */
+/* $Header$ */
+#include "Lpars.h"
+
+char *
+symbol2str(tok)
+	int tok;
+{
+#define SIZBUF	8
+	/* allow for a few invocations in f.i. an argument list */
+	static char buf[SIZBUF] = { '\'', 0, '\'', 0, '\'', 0, '\'', 0};
+	static int index = 1;
+
+	switch (tok) {
+--EOT--
+
+sed '
+/{[A-Z]/!d
+s/.*{\(.*\),.*\(".*"\).*$/	case \1 :\
+		return \2;/
+'
+
+cat <<'--EOT--'
+	default:
+		if (tok <= 0) return "end of file";
+		if (tok == '\n') return "<newline>";
+		if (tok < 040 || tok >= 0177) {
+			return "bad token";
+		}
+		index = (index+4) & (SIZBUF-1);
+		buf[index] = tok;
+		return &buf[index-1];
+	}
+}
+--EOT--

util/grind/make.tokfile

@@ -0,0 +1,6 @@
+sed '
+/{[A-Z]/!d
+s/.*{//
+s/,.*//
+s/.*/%token	&;/
+'

util/grind/message.h

@@ -0,0 +1,59 @@
+/* $Header$ */
+
+#define BUFLEN	24	/* size of buffer in message header */
+
+struct message_hdr {
+  int	m_type;
+/* Possible values of m_type: */
+#define DB_RUN	020000	/* set for commands that cause child to run */
+#define	SETBP	 0	/* set breakpoint at address in m_size */
+#define	CLRBP	 1	/* clear breakpoint at address in m_size */
+#define	SETSS	 (2|DB_RUN)	/* set single stepping, # of steps in m_size */
+#define SETSSF	 (3|DB_RUN)	/* set single stepping, counting calls as one step */
+#define	GETEMREGS 4	/* get EM registers, m_size contains level */
+#define	GETBYTES 5	/* get data; m_size contains size, m_buf contains address */
+#define GETSTR	 6	/* get string; m_buf contains address */
+#define SETBYTES 7	/* set data; m_buf contains address, m_size contains size */
+#define CALL	 8	/* call function; 
+			   m_size contains size of parameter buffer,
+			   m_buf contains address + size of function result
+			*/
+#define CONT	 (9|DB_RUN)	/* continue */
+#define	SETEMREGS 10	/* set EM registers, m_size contains level
+			   Actually, only the program counter is set.
+			*/
+#define DB_SS	040000	/* debugger wants single stepping (to be orred with
+			   SETSS(F) or CONT
+			*/
+#define CLRSS	12	/* clear single stepping */
+#define DUMP	13	/* dump command */
+#define DGLOB	14	/* data area */
+#define DSTACK	15	/* stack area */
+#define SETTRACE 16	/* start tracing; range in m_mes */
+#define CLRTRACE 17	/* end tracing */
+
+#define	OK	50	/* answer of child to most messages */
+#define FAIL	51	/* answer of child when something goes wrong */
+#define DATA	52	/* answer of child when data requested */
+#define END_SS	53	/* when stopped because of user single stepping */
+  long	m_size;		/* size */
+  char	m_buf[BUFLEN];	/* some of the data required included in message */
+};
+
+#define	LB_OFF	0
+#define AB_OFF	1
+#define PC_OFF	2
+#define HP_OFF	3
+#define SP_OFF	4
+
+#define IN_FD	3
+#define OUT_FD	6
+
+#define BUFTOL(c)	(*((long *) (c)))
+#define LTOBUF(c,l)	(*((long *) (c)) = (l))
+#define BUFTOA(c)	(*((char **) (c)))
+#define ATOBUF(c,p)	(*((char **) (c)) = (p))
+#define BUFTOS(c)	(*((short *) (c)))
+#define BUFTOI(c)	(*((int *) (c)))
+#define BUFTOF(c)	(*((float *) (c)))
+#define BUFTOD(c)	(*((double *) (c)))

util/grind/modula-2.c

@@ -0,0 +1,61 @@
+/* $Header$ */
+
+/* Language dependant support; this one is for Modula-2 */
+
+#include <stdio.h>
+
+#include "langdep.h"
+
+extern FILE *db_out;
+
+static int
+	print_string();
+
+static long
+	array_elsize();
+
+static struct langdep m2 = {
+	"%ld",
+	"%loB",
+	"%lXH",
+	"%lu",
+	"%lXH",
+	"%g",
+	"%oC",
+
+	"[",
+	"]",
+	"(",
+	")",
+	"{",
+	"}",
+
+	print_string,
+	array_elsize
+};
+
+struct langdep *m2_dep = &m2;
+
+static int
+print_string(s)
+  char	*s;
+{
+  register char	*str = s;
+  int delim = '\'';
+
+  while (*str) {
+	if (*str++ == '\'') delim = '"';
+  }
+  fprintf(db_out, "%c%s%c", delim, s, delim);
+}
+
+extern long	int_size;
+
+static long
+array_elsize(size)
+  long	size;
+{
+  if (! (int_size % size)) return size;
+  if (! (size % int_size)) return size;
+  return ((size + int_size - 1) / int_size) * int_size;
+}

util/grind/op_tools.amk

@@ -0,0 +1,14 @@
+MAKE_OPS = make.ops;
+
+%instance deftypesuffix(op_tab, '%.ot');
+
+%tool gen_ops (
+    ops:	%in  [type = op_tab];
+    cfile:	%out [type = C-src]	=> ops.c;
+    hfile:	%out [type = C-incl]	=> ops.h;
+    mkops:	%in  [type = command]	=> $MAKE_OPS;
+)
+{
+    exec($mkops, args => $ops);
+    echo({$cfile, 'and', $hfile, 'created'});
+};

util/grind/operator.h

@@ -0,0 +1,12 @@
+/* $Header$ */
+
+#include "ops.h"
+
+typedef struct operator {
+	int	op_nargs;
+	int	(*op_fun)();
+} t_operator, *p_operator;
+
+extern t_operator operators[];
+
+#define nargs(n)	(operators[(n)].op_nargs)

util/grind/operators.ot

@@ -0,0 +1,24 @@
+OP_LIST		2	do_list
+OP_FILE		1	do_file
+OP_LINK		2	0
+OP_RUN		1	start_child
+OP_INPUT	1	0
+OP_OUTPUT	1	0
+OP_INTEGER	0	0
+OP_NAME		0	0
+OP_AT		0	0
+OP_IN		1	0
+OP_STOP		2	do_stop
+OP_WHEN		3	do_stop
+OP_CONT		2	do_continue
+OP_STEP		0	do_step
+OP_NEXT		0	do_next
+OP_REGS		0	do_regs
+OP_WHERE	0	do_where
+OP_STATUS	0	do_status
+OP_DELETE	0	do_delete
+OP_SELECT	2	0
+OP_PRINT	1	do_print
+OP_DUMP		0	do_dump
+OP_RESTORE	0	do_restore
+OP_TRACE	3	do_trace

util/grind/position.c

@@ -0,0 +1,196 @@
+/* $Header$ */
+
+#include	<stdio.h>
+#include	<assert.h>
+#include	<alloc.h>
+#include	<out.h>
+#include	<stb.h>
+
+#include	"position.h"
+#include	"scope.h"
+#include	"file.h"
+#include	"idf.h"
+#include	"symbol.h"
+
+extern FILE	*db_out;
+
+static p_file	mapping;
+static int	nfiles = 0;
+
+/* static p_file get_map_from_addr(t_addr t);
+   Returns the file entry that contains the code at the address 't',
+   or 0 if there is no information available, or 't' represents an address
+   below the start address of the first file.
+*/
+static p_file
+get_map_from_addr(t)
+  t_addr t;
+{
+  register p_file p = mapping, oldp = 0;
+
+  /* linear search is probably acceptable here */
+  while (p && p->f_start->on_valu <= t) {
+	oldp = p;
+	p = p->f_nextmap;
+  }
+  return oldp ? oldp : p->f_start->on_valu <= t ? p : 0;
+}
+
+/* extern char *get_filename_from_addr(t_addr t);
+   Returns the source filename that contains the code at the address 't',
+   or 0 if there is no information available, or 't' represents an address
+   below the start address of the first file.
+*/
+char *
+get_filename_from_addr(t)
+  t_addr t;
+{
+  register p_file map = get_map_from_addr(t);
+
+  if (! map) return 0;
+  return map->f_sym->sy_idf->id_text;
+}
+
+/* extern t_lineno get_lineno_from_addr(t_addr t);
+   Returns the source line number of the line that contains the code at address
+   't'.  0 is returned if no source line number could be found.
+*/
+t_lineno
+get_lineno_from_addr(t)
+  t_addr t;
+{
+  p_position p;
+
+  p = get_position_from_addr(t);
+  return p == 0 ? 0 : p->lineno;
+}
+
+/* extern p_position get_position_from_addr(t_addr t);
+   Returns a pointer to a structure containing the source position of the code
+   at address 't'.  0 is returned if no source position could be found.
+*/
+p_position
+get_position_from_addr(t)
+  t_addr t;
+{
+  register p_file map = get_map_from_addr(t);
+  static t_position retval;
+  register int i,j,m;
+
+  if (! map) return 0;
+  i = 0;
+  j = map->f_end - map->f_start;
+  do {
+	m = ((i + j) >> 1) + ((i + j) & 1);
+	while ((map->f_start[m].on_type >> 8) != N_SLINE) m++;
+	assert(m <= j);
+	if (map->f_start[m].on_valu > t) {
+		j = m - 1;
+		while (j > i && (map->f_start[j].on_type >> 8) != N_SLINE) j--;
+	}
+	else	i = m;
+  } while (i < j);
+  retval.filename = map->f_sym->sy_idf->id_text;
+  retval.lineno = map->f_start[j].on_desc;
+  return &retval;
+}
+
+/* extern t_addr get_addr_from_position(p_position p);
+   Returns the address of the code at position 'p', or ILL_ADDR if it could
+   not be found. If there is no symbolic information for the filename in
+   position 'p', an error message will be given.
+*/
+t_addr
+get_addr_from_position(p)
+  p_position p;
+{
+  register p_symbol sym = Lookup(findidf(p->filename), PervasiveScope, FILESYM);
+
+  if (sym) {
+	register unsigned int i;
+	register p_file map = sym->sy_file;
+
+	for (i = p->lineno; i > 0; i--) {
+		register struct outname *n = map->f_line_addr[HASH(i)];
+
+		while (n) {
+			if (n->on_desc == i) return (t_addr) n->on_valu;
+			n = next_outname(n);
+		}
+	}
+	return ILL_ADDR;
+  }
+  error("no symbolic information for file %s", p->filename);
+  return ILL_ADDR;
+}
+
+/* extern add_position_addr(char *filename, struct outname *n);
+   Adds the ('filename','lineno'),'t' pair to the mapping information.
+*/
+add_position_addr(filename, n)
+  char *filename;
+  register struct outname *n;
+{
+  static char *lastfile = 0;
+  static p_file lastmap = 0;
+  register p_file map = lastmap;
+
+  if (filename != lastfile) {	/* new file ... */
+	register p_symbol sym;
+
+	nfiles++;
+	lastfile = filename;
+	if (! filename) {	/* last call */
+		return;
+	}
+	sym = Lookup(findidf(filename), PervasiveScope, FILESYM);
+	if (sym) map = sym->sy_file; 
+	else {
+		sym = add_file(filename);
+		map = sym->sy_file;
+		map->f_scope = FileScope;
+	}
+	if (! mapping) mapping = map;
+	else lastmap->f_nextmap = map;
+	lastmap = map;
+	map->f_start = n;
+  }
+  else map = lastmap;
+  map->f_end = n;
+  setnext_outname(n, map->f_line_addr[HASH(n->on_desc)]);
+  map->f_line_addr[HASH(n->on_desc)] = n;
+}
+
+/* extern struct scope  *get_scope_from_position(p_position p);
+   Returns the scope of the code at position 'p', or 0 if it could not be found.
+*/
+struct scope *
+get_scope_from_position(p)
+  p_position p;
+{
+  t_addr a = get_addr_from_position(p);
+
+  if (a != ILL_ADDR) {
+	return get_scope_from_addr(a);
+  }
+  return 0;
+}
+
+/* extern p_position print_position(t_addr a, int print_function);
+   Prints position 'a' and returns it. If 'print_function' is set,
+   an attempt is made to print the function name as well.
+*/
+p_position
+print_position(a, print_function)
+  t_addr	a;
+  int		print_function;
+{
+  register p_scope	sc = base_scope(get_scope_from_addr(a));
+  register p_position	pos = get_position_from_addr(a);
+
+  if (sc && print_function) {
+	fprintf(db_out, "in %s ", sc->sc_definedby->sy_idf->id_text);
+  }
+  if (pos) fprintf(db_out, "at \"%s\":%u", pos->filename, pos->lineno);
+  return pos;
+}

util/grind/position.h

@@ -0,0 +1,57 @@
+/* $Header$ */
+
+/* maps from address to filename-lineno pair and reverse,
+   maps from filename-lineno pair or address to scope.
+*/
+
+typedef unsigned int	t_lineno;
+typedef long		t_addr;
+#define ILL_ADDR	((t_addr) -1)
+#define NO_ADDR		((t_addr) -3)
+
+typedef struct pos {
+  t_lineno	lineno;
+  char		*filename;
+} t_position, *p_position;
+
+/* extern char *get_filename_from_addr(t_addr t);
+   Returns the source filename that contains the code at the address 't',
+   or 0 if there is no information available, or 't' represents an address
+   below the start address of the first file.
+*/
+extern char		*get_filename_from_addr();
+
+/* extern t_lineno	get_lineno_from_addr(t_addr t);
+   Returns the source line number of the line that contains the code at address
+   't'.  0 is returned if no source line number could be found.
+*/
+extern t_lineno		get_lineno_from_addr();
+
+/* extern p_position	get_position_from_addr(t_addr t);
+   Returns a pointer to a structure containing the source position of the code
+   at address 't'.  0 is returned if no source position could be found.
+*/
+extern p_position	get_position_from_addr();
+
+/* extern t_addr	get_addr_from_position(p_position p);
+   Returns the address of the code at position 'p', or ILL_ADDR if it could
+   not be found. If there is no symbolic information for the filename in
+   position 'p', an error message will be given.
+*/
+extern t_addr		get_addr_from_position();
+
+/* extern	add_position_addr(char *filename, struct outname *n);
+   Adds the ('filename','n'->on_desc),'n'->on_valu pair to the mapping information.
+*/
+extern 			add_position_addr();
+
+/* extern struct scope	*get_scope_from_position(p_position p);
+   Returns the scope of the code at position 'p', or 0 if it could not be found.
+*/
+extern struct scope	*get_scope_from_position();
+
+/* extern p_position print_position(t_addr a, int print_function);
+   Prints position 'a' and returns it. If 'print_function' is set,
+   an attempt is made to print the function name as well.
+*/
+extern p_position	print_position();

util/grind/print.c

@@ -0,0 +1,322 @@
+/* $Header$ */
+
+#include <alloc.h>
+#include <assert.h>
+#include <stdio.h>
+
+#include "type.h"
+#include "message.h"
+#include "langdep.h"
+#include "scope.h"
+#include "symbol.h"
+#include "position.h"
+#include "idf.h"
+
+extern FILE *db_out;
+extern long float_size, pointer_size, int_size;
+
+static
+print_literal(tp, v)
+  p_type	tp;
+  int		v;
+{
+  register struct literal *lit = tp->ty_literals;
+  register int i;
+
+  for (i = tp->ty_nenums; i; i--, lit++) {
+	if (lit->lit_val == v) {
+		fprintf(db_out, lit->lit_name);
+		break;
+	}
+  }
+  if (! i) {
+	fprintf(db_out, "unknown enumeration value %d", v);
+  }
+}
+
+static
+print_unsigned(tp, v)
+  p_type	tp;
+  long		v;
+{
+  if (tp == uchar_type) {
+	fprintf(db_out, currlang->char_fmt, (int) v);
+  }
+  else	fprintf(db_out, currlang->uns_fmt, v);
+}
+
+static
+print_integer(tp, v)
+  p_type	tp;
+  long		v;
+{
+  if (tp == char_type) {
+	fprintf(db_out, currlang->char_fmt, (int) v);
+  }
+  else	fprintf(db_out, currlang->decint_fmt, v);
+}
+
+print_params(tp, AB, static_link)
+  p_type	tp;
+  t_addr	AB;
+{
+  char *param_bytes;
+  register char *p;
+  register int i;
+  register struct param *par;
+  long size;
+
+  if (! tp) return;
+  assert(tp->ty_class == T_PROCEDURE);
+
+  if ((i = tp->ty_nparams) == 0) return;
+
+  /* get parameter bytes */
+  par = tp->ty_params;
+  size = tp->ty_nbparams;
+  if (static_link) size += pointer_size;
+  param_bytes = p = Malloc((unsigned)size);
+  if (static_link) p += pointer_size;
+  if (! get_bytes(size, AB, param_bytes)) {
+	error("no debuggee");
+	free(param_bytes);
+	return;
+  }
+
+  while (i--) {
+	if (par->par_kind == 'v' || par->par_kind == 'i') {
+		/* call by reference parameter, or
+		   call by value parameter, but address is passed;
+		   try and get value.
+		*/
+		char	*q;
+
+		if ((size = par->par_type->ty_size) == 0) {
+			size = compute_size(par->par_type, param_bytes);
+		}
+		q = Malloc((unsigned) size);
+		if (! get_bytes(size, (t_addr) BUFTOA(p), q)) {
+			fprintf(db_out, currlang->addr_fmt, BUFTOA(p));
+		}
+		else {
+			print_val(par->par_type, q, 1, 0, param_bytes);
+		}
+		free(q);
+	}
+	else print_val(par->par_type, p, 1, 0, param_bytes);
+	if (i) fputs(", ", db_out);
+	p += param_size(par->par_type, par->par_kind);
+	par++;
+  }
+  free(param_bytes);
+}
+
+print_val(tp, addr, compressed, indent, AB)
+  p_type	tp;		/* type of value to be printed */
+  char		*addr;		/* address to get value from */
+  int		compressed;	/* for parameter lists */
+  int		indent;		/* indentation */
+  char		*AB;		/* argument base for dynamic subranges */
+{
+  long sz;
+  register int i;
+  long elsize;
+
+  if (indent == 0) indent = 4;
+  switch(tp->ty_class) {
+  case T_SUBRANGE:
+	print_val(tp->ty_base, addr, compressed, indent, AB);
+	break;
+  case T_ARRAY:
+	if (tp->ty_elements == char_type ||
+	    tp->ty_elements == uchar_type) {
+		print_val(string_type, addr, compressed, indent, AB);
+		break;
+	}
+	if ((sz = tp->ty_size) == 0) sz = compute_size(tp, AB);
+	if (compressed) {
+		fprintf(db_out, currlang->open_array_display);
+	}
+	else {
+		fprintf(db_out, "\n%*c%s%*c",
+			indent,
+			' ',
+			currlang->open_array_display,
+			4-strlen(currlang->open_array_display), ' ');
+	}
+	indent += 4;
+	elsize = (*currlang->arrayelsize)(tp->ty_elements->ty_size);
+	for (i = sz/elsize; i; i--) {
+		print_val(tp->ty_elements, addr, compressed, indent, AB);
+		addr += elsize;
+		if (compressed && i > 1) {
+			fprintf(db_out, ", ...");
+			break;
+		} 
+		if (i > 1) {
+			fputc(',', db_out);
+		}
+		fprintf(db_out, "\n%*c", i > 1 ? indent : indent - 4, ' ');
+	}
+	fprintf(db_out, currlang->close_array_display);
+	indent -= 4;
+	break;
+  case T_STRUCT: {
+	register struct fields *fld = tp->ty_fields;
+
+	if (compressed) {
+		fprintf(db_out, currlang->open_struct_display);
+	}
+	else {
+		fprintf(db_out, "\n%*c%s%*c",
+			indent,
+			' ',
+			currlang->open_struct_display,
+			4-strlen(currlang->open_struct_display), ' ');
+	}
+	indent += 4;
+	for (i = tp->ty_nfields; i; i--, fld++) {
+		if (! compressed) fprintf(db_out, "%s = ", fld->fld_name);
+		if (fld->fld_bitsize != fld->fld_type->ty_size << 3) {
+			/* apparently a bit field */
+			/* ??? */
+			fprintf(db_out, "<bitfield, %d, %d>", fld->fld_bitsize, fld->fld_type->ty_size);
+		}
+		else print_val(fld->fld_type, addr+(fld->fld_pos>>3), compressed, indent, AB);
+		if (compressed && i > 1) {
+			fprintf(db_out, ", ...");
+			break;
+		} 
+		if (i > 1) {
+			fputc(',', db_out);
+		}
+		fprintf(db_out, "\n%*c", i > 1 ? indent : indent - 4, ' ');
+	}
+	indent -= 4;
+	fprintf(db_out, currlang->close_struct_display);
+	break;
+	}
+  case T_UNION:
+	fprintf(db_out, "<union>");
+	break;
+  case T_ENUM:
+	print_literal(tp,  tp->ty_size == 1 
+			   ? (*addr & 0xFF)
+			   : tp->ty_size == 2
+			      ? (BUFTOS(addr) & 0xFFFF)
+			      : (int) BUFTOL(addr));
+	break;
+  case T_PROCEDURE: {
+	register p_scope sc = get_scope_from_addr((t_addr) BUFTOA(addr));
+
+	if (sc && sc->sc_definedby) {
+		fprintf(db_out, sc->sc_definedby->sy_idf->id_text);
+		break;
+	}
+	}
+	/* Fall through */
+  case T_POINTER:
+	fprintf(db_out, currlang->addr_fmt, (long) BUFTOA(addr));
+	break;
+  case T_FILE:
+	fprintf(db_out, "<file>");
+	break;
+  case T_SET: {
+	long	val = tp->ty_setlow;
+	p_type	base = tp->ty_setbase;
+	long	nelements = tp->ty_size << 3;
+	int	count = 0;
+	int	rsft = 3 + (int_size == 2 ? 1 : 2);
+	long	mask = int_size == 2 ? 0xFFFF : 0xFFFFFFFF;
+
+	if (base->ty_class == T_SUBRANGE) base = base->ty_base;
+	if (compressed) {
+		fprintf(db_out, currlang->open_set_display);
+	}
+	else {
+		fprintf(db_out, "\n%*c%s%*c",
+			indent,
+			' ',
+			currlang->open_set_display,
+			4-strlen(currlang->open_set_display), ' ');
+	}
+	indent += 4;
+	for (i = 0; i < nelements; i++) {
+		if (*((int *) addr + (i >> rsft)) & (1 << (i & mask))) {
+			count++;
+			if (count > 1) {
+				if (compressed) {
+					fprintf(db_out, ", ...");
+					break;
+				}
+				fprintf(db_out, ",\n%*c", indent , ' ');
+			}
+			switch(base->ty_class) {
+			case T_INTEGER:
+				print_integer(base, val+i);
+				break;
+			case T_UNSIGNED:
+				print_unsigned(base, val+i);
+				break;
+			case T_ENUM:
+				print_literal(base, (int)val+i);
+				break;
+			default:
+				assert(0);
+			}
+		} 
+	}
+	if (! compressed) {
+		fprintf(db_out, "\n%*c", indent-4 , ' ');
+	}
+	indent -= 4;
+	fprintf(db_out, currlang->close_set_display);
+  	}
+	break;
+  case T_REAL: {
+	double val = tp->ty_size == float_size
+		? BUFTOF(addr)
+		: BUFTOD(addr);
+	fprintf(db_out, currlang->real_fmt, val);
+	break;
+	}
+  case T_UNSIGNED:
+	print_unsigned(tp, tp->ty_size == 1 
+				? (*addr & 0xFF)
+				: tp->ty_size == 2
+			  	    ? (BUFTOS(addr) & 0xFFFF)
+			  	    : BUFTOL(addr));
+	break;
+  case T_INTEGER:
+	print_integer(tp, tp->ty_size == 1 
+				? *addr
+				: tp->ty_size == 2
+			  	    ? BUFTOS(addr)
+			  	    : BUFTOL(addr));
+	break;
+  case T_STRING:
+	(*currlang->printstring)(addr);
+	break;
+  default:
+	assert(0);
+	break;
+  }
+}
+
+int
+print_sym(sym)
+  p_symbol	sym;
+{
+  char		*buf;
+  char		*AB;
+
+  if (get_value(sym, &buf, &AB)) {
+	fputs(" = ", db_out);
+	print_val(sym->sy_type, buf, 0, 0, AB);
+	if (buf) free(buf);
+	if (AB) free(AB);
+	fputs("\n", db_out);
+	return 1;
+  }
+  return 0;
+}

util/grind/rd.c

@@ -0,0 +1,134 @@
+/* $Header$ */
+
+/* a.out file reading ... */
+
+#include "rd.h"
+
+#if defined(sun) && defined(mc68020)
+
+#include <a.out.h>
+#include <stdio.h>
+
+static FILE *inf;
+static struct exec bh;
+static long seg_strings;
+static struct outhead hh;
+
+#define readf(a, b, c)	(fread((char *)(a), (b), (int)(c), inf))
+
+int
+rd_open(f)
+  char	*f;
+{
+  if ((inf = fopen(f, "r")) == NULL) return 0;
+  return 1;
+}
+
+rd_ohead(h)
+  struct outhead	*h;
+{
+  if (! readf(&bh, sizeof(struct exec), 1)) rd_fatal();
+  if (N_BADMAG(bh)) rd_fatal();
+
+  h->oh_magic = O_CONVERTED;
+  h->oh_stamp = 0;
+  h->oh_nsect = 4;
+  h->oh_nname = 3 + bh.a_syms / sizeof(struct nlist);
+  h->oh_nrelo = (bh.a_trsize + bh.a_drsize) / sizeof(struct reloc_info_68k);
+  h->oh_flags = h->oh_nrelo ? HF_LINK : 0;
+  if (bh.a_magic == ZMAGIC) bh.a_text -= sizeof(struct exec);
+  h->oh_nemit = bh.a_text + bh.a_data;
+  if (bh.a_magic == ZMAGIC) bh.a_text += sizeof(struct exec);
+  fseek(inf, N_STROFF(bh), 0);
+  h->oh_nchar = getw(inf) + 6 + 6 + 5 - 4; /* ".text", ".data", ".bss",
+					      minus the size word */
+  seg_strings = h->oh_nchar - 17;
+  if (bh.a_magic == ZMAGIC) bh.a_text -= sizeof(struct exec);
+  fseek(inf, sizeof(struct exec) + bh.a_text + bh.a_data, 0);
+  hh = *h;
+}
+
+/*ARGSUSED1*/
+rd_name(names, count)
+  register struct outname	*names;
+  unsigned int		count;	/* ignored; complete namelist is read */
+{
+  names->on_valu = 0; names->on_foff = seg_strings + OFF_CHAR(hh);
+  names->on_desc = 0; names->on_type = S_MIN | S_SCT;
+  names++;
+  names->on_valu = 0; names->on_foff = seg_strings + OFF_CHAR(hh) + 6;
+  names->on_desc = 0; names->on_type = (S_MIN+2) | S_SCT;
+  names++;
+  names->on_valu = 0; names->on_foff = seg_strings + OFF_CHAR(hh) + 12;
+  names->on_desc = 0; names->on_type = (S_MIN+3) | S_SCT;
+  names++;
+  count = bh.a_syms / sizeof(struct nlist);
+  while (count > 0) {
+	struct nlist n;
+
+	if (! readf(&n, sizeof(struct nlist), 1)) rd_fatal();
+	count--;
+	names->on_desc = n.n_desc;
+	if (n.n_un.n_strx - 4 < 0) names->on_foff = 0;
+	else names->on_foff = OFF_CHAR(hh) - 4 + n.n_un.n_strx;
+	names->on_valu = n.n_value;
+
+	if (n.n_type & N_STAB) {
+		names->on_type = n.n_type << 8;
+		names++;
+		continue;
+	}
+	switch(n.n_type & ~N_EXT) {
+	case N_ABS:
+		names->on_type = S_ABS;
+		break;
+	case N_TEXT:
+		names->on_type = S_MIN;
+		break;
+	case N_DATA:
+		names->on_type = S_MIN + 2;
+		names->on_valu -= bh.a_text;
+		break;
+	case N_BSS:
+		names->on_type = S_MIN + 3;
+		names->on_valu -= bh.a_text + bh.a_data;
+		break;
+	case N_UNDF:
+		if (! names->on_valu) {
+			names->on_type = S_UND;
+			break;
+		}
+		names->on_type = (S_MIN + 3) | S_COM;
+		break;
+	case N_FN:
+		names->on_type = S_FIL;
+		break;
+	default:
+		rd_fatal();
+	}
+	if (n.n_type & N_EXT) names->on_type |= S_EXT;
+	names++;
+  }
+}
+
+extern char	*strcpy();
+
+rd_string(strings, count)
+  register char	*strings;
+  long	count;
+{
+  if (bh.a_magic == ZMAGIC) bh.a_text += sizeof(struct exec);
+  fseek(inf, N_STROFF(bh)+4, 0);
+  if (! readf(strings, (int)count-17, 1)) rd_fatal();
+  strings += count-17;
+  strcpy(strings, ".text"); strings += 6;
+  strcpy(strings, ".data"); strings += 6;
+  strcpy(strings, ".bss");
+}
+
+rd_close()
+{
+  fclose(inf);
+}
+
+#endif

util/grind/rd.h

@@ -0,0 +1,5 @@
+/* $Header$ */
+
+#include	<out.h>
+
+#define O_CONVERTED	0x202

util/grind/run.c

@@ -0,0 +1,523 @@
+/* $Header$ */
+
+/* Running a process and communication */
+
+#include <signal.h>
+#include <stdio.h>
+#include <assert.h>
+#include <alloc.h>
+
+#include "ops.h"
+#include "message.h"
+#include "position.h"
+#include "tree.h"
+#include "file.h"
+#include "symbol.h"
+#include "idf.h"
+#include "scope.h"
+
+#define MAXARG	128
+
+extern char	*strncpy();
+extern char	*AObj;
+extern t_lineno	currline;
+extern FILE	*db_out;
+extern int	debug;
+extern struct idf *str2idf();
+extern long	pointer_size;
+
+static int	child_pid;		/* process id of child */
+static int	to_child, from_child;	/* file descriptors for communication */
+static int	child_status;
+static int	restoring;
+
+int		db_ss;
+
+static int	catch_sigpipe();
+static int	stopped();
+static int	uputm(), ugetm();
+static int	fild1[2], fild2[2];	/* pipe file descriptors */
+
+int
+init_run()
+{
+  /* take file descriptors so that listing cannot take them */
+  int i;
+
+  for (i = IN_FD; i <= OUT_FD; i++) close(i);
+  if (pipe(fild1) < 0 ||
+      pipe(fild2) < 0 ||
+      fild1[0] != IN_FD ||
+      fild2[1] != OUT_FD) {
+	return 0;
+  }
+  to_child = fild1[1];
+  from_child = fild2[0];
+  return 1;
+}
+
+int
+start_child(p)
+  p_tree	p;
+{
+  /* start up the process to be debugged and set up communication */
+
+  char *argp[MAXARG];				/* argument list */
+  register p_tree pt = p->t_args[0], pt1;
+  unsigned int	nargs = 1;			/* #args */
+  char	*in_redirect = 0;			/* standard input redirected */
+  char	*out_redirect = 0;			/* standard output redirected */
+
+  signal_child(SIGKILL); /* like families in China, this debugger is only
+			    allowed one child
+			 */
+
+  /* first check arguments and redirections and build argument list */
+  while (pt) {
+  	switch(pt->t_oper) {
+	case OP_LINK:
+		pt1 = pt->t_args[1];
+		pt = pt->t_args[0];
+		continue;
+	case OP_NAME:
+		if (nargs < (MAXARG-1)) {
+			argp[nargs++] = pt->t_str;
+		}
+		else {
+			error("too many arguments");
+			return 0;
+		}
+		break;
+	case OP_INPUT:
+		if (in_redirect) {
+			error("input redirected twice?");
+			return 0;
+		}
+		in_redirect = pt->t_str;
+		break;
+	case OP_OUTPUT:
+		if (out_redirect) {
+			error("output redirected twice?");
+			return 0;
+		}
+		out_redirect = pt->t_str;
+		break;
+  	}
+	if (pt != pt1) pt = pt1;
+	else break;
+  }
+  argp[0] = AObj;
+  argp[nargs] = 0;
+
+  /* create child process */
+  child_pid = fork();
+  if (child_pid < 0) {
+	error("could not create child");
+	return 0;
+  }
+  if (child_pid == 0) {
+	/* this is the child process */
+	close(fild1[1]);
+	close(fild2[0]);
+
+	signal(SIGINT, SIG_IGN);
+
+	/* I/O redirection */
+	if (in_redirect) {
+		int fd;
+		close(0);
+		if ((fd = open(in_redirect, 0)) < 0) {
+			error("could not open input file");
+			exit(-1);
+		}
+		if (fd != 0) {
+			dup2(fd, 0);
+			close(fd);
+		}
+	}
+	if (out_redirect) {
+		int fd;
+		close(1);
+		if ((fd = creat(in_redirect, 0666)) < 0) {
+			error("could not open output file");
+			exit(-1);
+		}
+		if (fd != 1) {
+			dup2(fd, 1);
+			close(fd);
+		}
+	}
+
+	/* and run process to be debugged */
+	execv(AObj, argp);
+	error("could not exec %s", AObj);
+	exit(-1);
+  }
+
+  /* debugger */
+  close(fild1[0]);
+  close(fild2[1]);
+
+  pipe(fild1);		/* to occupy file descriptors */
+  signal(SIGPIPE, catch_sigpipe);
+  if (! wait_for_child((char *) 0)) {
+	error("child not responding");
+	return 0;
+  }
+  do_items();
+  if (! restoring) send_cont(1);
+  return 1;
+}
+
+int
+wait_for_child(s)
+  char	*s;		/* to pass on to 'stopped' */
+{
+  struct message_hdr m;
+
+  if (child_pid) {
+  	if (ugetm(&m)) {
+		return stopped(s, (t_addr) m.m_size);
+  	}
+  	return 0;
+  }
+  return 1;
+}
+
+signal_child(sig)
+{
+  if (child_pid) {
+	kill(child_pid, sig);
+	if (sig == SIGKILL) {
+		wait(&child_status);
+		init_run();
+	}
+  }
+}
+
+static int
+catch_sigpipe()
+{
+  child_pid = 0;
+}
+
+
+static int
+ureceive(p, c)
+  char	*p;
+  long	c;
+{
+  int	i;
+
+  if (! child_pid) return 0;
+
+  while (c >= 0x1000) {
+	i = read(from_child, p, 0x1000);
+	if (i <= 0) {
+		if (i == 0) child_pid = 0;
+		return 0;
+	}
+	p += i;
+	c -= i;
+  }
+  while (c > 0) {
+	i = read(from_child, p, (int)c);
+	if (i <= 0) {
+		if (i == 0) child_pid = 0;
+		return 0;
+	}
+	p += i;
+	c -= i;
+  }
+  return c == 0;
+}
+
+static int
+usend(p, c)
+  char	*p;
+  long	c;
+{
+  int	i;
+
+  while (c >= 0x1000) {
+	i = write(to_child, p, 0x1000);
+	if (i < 0) return 0;
+	p += i;
+	c -= i;
+  }
+  while (c > 0) {
+	i = write(to_child, p, (int)c);
+	if (i < 0) return 0;
+	p += i;
+	c -= i;
+  }
+  return 1;
+}
+
+static int
+ugetm(message)
+  struct message_hdr *message;
+{
+  if (! ureceive((char *) message, (long) sizeof(struct message_hdr))) {
+  	return 0;
+  }
+  if (debug) printf("Got %d\n", message->m_type);
+  return 1;
+}
+
+static int
+uputm(message)
+  struct message_hdr *message;
+{
+  if (! usend((char *) message, (long) sizeof(struct message_hdr))) {
+  	return 0;
+  }
+  if (debug) printf("Sent %d\n", message->m_type);
+  return 1;
+}
+
+static struct message_hdr	answer;
+static int	single_stepping;
+
+static int
+stopped(s, a)
+  char	*s;	/* stop message */
+  t_addr a;	/* address where stopped */
+{
+  p_position pos;
+
+  if (s) {
+	fprintf(db_out, "%s ", s);
+	pos = print_position((t_addr) a, 1);
+	newfile(str2idf(pos->filename, 1));
+	currline = pos->lineno;
+	fputs("\n", db_out);
+	lines(currfile->sy_file, (int)currline, (int)currline);
+  }
+  return 1;
+}
+
+static int
+could_send(m, stop_message)
+  struct message_hdr	*m;
+{
+  int	type;
+  t_addr a;
+  for (;;) {
+  	if (child_pid) {
+		if (! uputm(m) ||
+		    ! ugetm(&answer)) {
+			if (child_pid) {
+				error("something wrong!");
+				return 1;
+			}
+			wait(&child_status);
+			init_run();
+			if (child_status & 0177) {
+				fprintf(db_out,
+					"Child died with signal %d\n",
+					child_status & 0177);
+			}
+			else {
+				fprintf(db_out,
+					"Child terminated, exit status %d\n",
+					child_status >> 8);
+			}
+			return 1;
+		}
+		a = answer.m_size;
+		type = answer.m_type;
+		if (m->m_type & DB_RUN) {
+			/* run command */
+			CurrentScope = get_scope_from_addr((t_addr) a);
+		    	if (! item_addr_actions(a) &&
+		            ( type == DB_SS || type == OK)) {
+				/* no explicit breakpoints at this position.
+				   Also, child did not stop because of
+				   SETSS or SETSSF, otherwise we would
+				   have gotten END_SS.
+				   So, continue.
+				*/
+				if ((m->m_type & ~ DB_SS) != CONT) {
+					m->m_type = CONT | (m->m_type & DB_SS);
+				}
+				continue;
+			}
+			if (type != END_SS && single_stepping) {
+				m->m_type = CLRSS;
+				uputm(m) && ugetm(&answer);
+			}
+			single_stepping = 0;
+		}
+		if (stop_message) stopped("stopped", a);
+		return 1;
+	}
+	return 0;
+  }
+  /*NOTREACHED*/
+}
+
+int
+get_bytes(size, from, to)
+  long	size;
+  t_addr from;
+  char	*to;
+{
+  struct message_hdr	m;
+
+  m.m_type = GETBYTES;
+  m.m_size = size;
+  ATOBUF(m.m_buf, (char *) from);
+
+  if (! could_send(&m, 0)) {
+	return 0;
+  }
+
+  assert(answer.m_type == DATA && answer.m_size == m.m_size);
+
+  return ureceive(to, answer.m_size);
+}
+
+int
+get_dump(globmessage, globbuf, stackmessage, stackbuf)
+  struct message_hdr *globmessage, *stackmessage;
+  char **globbuf, **stackbuf;
+{
+  struct message_hdr	m;
+
+  m.m_type = DUMP;
+  if (! could_send(&m, 0)) {
+	return 0;
+  }
+  assert(answer.m_type == DGLOB);
+  *globmessage = answer;
+  *globbuf = Malloc((unsigned) answer.m_size);
+  if (! ureceive(*globbuf, answer.m_size) || ! ugetm(stackmessage)) {
+	free(*globbuf);
+	return 0;
+  }
+  assert(stackmessage->m_type == DSTACK);
+  *stackbuf = Malloc((unsigned) stackmessage->m_size);
+  if (! ureceive(*stackbuf, stackmessage->m_size)) {
+	free(*globbuf);
+	free(*stackbuf);
+	return 0;
+  }
+  ATOBUF(globmessage->m_buf+SP_OFF*pointer_size,
+	 BUFTOA(stackmessage->m_buf+SP_OFF*pointer_size));
+  return 1;
+}
+
+int
+put_dump(globmessage, globbuf, stackmessage, stackbuf)
+  struct message_hdr *globmessage, *stackmessage;
+  char *globbuf, *stackbuf;
+{
+  struct message_hdr m;
+
+  if (! child_pid) {
+	restoring = 1;
+	start_child(run_command);
+	restoring = 0;
+  }
+  return	uputm(globmessage) &&
+		usend(globbuf, globmessage->m_size) &&
+		uputm(stackmessage) &&
+		usend(stackbuf, stackmessage->m_size) &&
+		ugetm(&m) && stopped("restored", m.m_size);
+}
+
+t_addr *
+get_EM_regs(level)
+  int	level;
+{
+  struct message_hdr	m;
+  static t_addr buf[5];
+  register t_addr *to = &buf[0];
+
+  m.m_type = GETEMREGS;
+  m.m_size = level;
+
+  if (! could_send(&m, 0)) {
+	return 0;
+  }
+  *to++ = (t_addr) BUFTOA(answer.m_buf);
+  *to++ = (t_addr) BUFTOA(answer.m_buf+pointer_size);
+  *to++ = (t_addr) BUFTOA(answer.m_buf+2*pointer_size);
+  *to++ = (t_addr) BUFTOA(answer.m_buf+3*pointer_size);
+  *to++ = (t_addr) BUFTOA(answer.m_buf+4*pointer_size);
+  return buf;
+}
+
+int
+set_pc(PC)
+  t_addr	PC;
+{
+  struct message_hdr	m;
+
+  m.m_type = SETEMREGS;
+  m.m_size = 0;
+  ATOBUF(m.m_buf+PC_OFF*pointer_size, (char *)PC);
+  return could_send(&m, 0);
+}
+
+int
+send_cont(stop_message)
+  int	stop_message;
+{
+  struct message_hdr	m;
+
+  m.m_type = (CONT | (db_ss ? DB_SS : 0));
+  m.m_size = 0;
+  return could_send(&m, stop_message);
+}
+
+int
+do_single_step(type, count)
+  int	type;
+  long	count;
+{
+  struct message_hdr	m;
+
+  m.m_type = type | (db_ss ? DB_SS : 0);
+  m.m_size = count;
+  single_stepping = 1;
+  if (could_send(&m, 1)) {
+	return 1;
+  }
+  single_stepping = 0;
+  return 0;
+}
+
+int
+set_or_clear_breakpoint(a, type)
+  t_addr	a;
+  int	type;
+{
+  struct message_hdr m;
+
+  if (a == ILL_ADDR || a == NO_ADDR) return 0;
+
+  m.m_type = type;
+  m.m_size = a;
+  if (debug) printf("%s breakpoint at 0x%lx\n", type == SETBP ? "setting" : "clearing", (long) a);
+  if (! could_send(&m, 0)) { }
+
+  return 1;
+}
+
+int
+set_or_clear_trace(start, end, type)
+  t_addr start, end;
+  int	type;
+{
+  struct message_hdr m;
+
+  m.m_type = type;
+  ATOBUF(m.m_buf, (char *) start);
+  ATOBUF(m.m_buf+pointer_size, (char *) end);
+  if (debug) printf("%s trace at [0x%lx,0x%lx]\n", type == SETTRACE ? "setting" : "clearing", (long) start, (long) end);
+  if (! could_send(&m, 0)) { }
+
+  return 1;
+}

util/grind/scope.cc

@@ -0,0 +1,131 @@
+/* Scope mechanism */
+
+/* $Header$ */
+
+#include	<assert.h>
+#include	<alloc.h>
+#include	<out.h>
+
+#include	"position.h"
+#include	"file.h"
+#include	"idf.h"
+#include	"type.h"
+#include	"symbol.h"
+#include	"scope.h"
+#include	"avl.h"
+
+p_scope PervasiveScope, CurrentScope, FileScope;
+
+/* STATICALLOCDEF "scope" 10 */
+
+static AVL_tree	ScopeTree;
+
+static int
+cmp_starts(s1, s2)
+  char	*s1, *s2;
+{
+  register p_scope c1 = (p_scope)s1, c2 = (p_scope)s2;
+
+  return c1->sc_start < c2->sc_start
+	 ? -1
+	 : c1->sc_start == c2->sc_start
+	   ? 0
+	   : 1;
+}
+
+/*ARGSUSED*/
+open_scope(name, has_activation)
+  p_symbol name;
+  int has_activation;
+{
+  register p_scope sc = new_scope();
+
+  sc->sc_has_activation_record = has_activation;
+  sc->sc_static_encl = CurrentScope;
+  sc->sc_definedby = name;
+  sc->sc_proclevel = CurrentScope->sc_proclevel;
+			/* sc_proclevel possibly reset by caller */
+  CurrentScope = sc;
+}
+
+init_scope()
+{
+  register p_scope sc = new_scope();
+
+  PervasiveScope = sc;
+  CurrentScope = sc;
+  open_scope((p_symbol) 0, 0);		/* this one will be closed at the
+					   first N_SO
+					*/
+  ScopeTree = create_avl_tree(cmp_starts);
+}
+
+close_scope()
+{
+  register p_scope sc = CurrentScope;
+
+  assert(sc != 0);
+  CurrentScope = sc->sc_static_encl;
+}
+
+add_scope_addr(scope)
+  p_scope	scope;
+{
+  add_to_avl_tree(ScopeTree, (char *)scope);
+}
+
+/* extern p_scope	get_scope_from_addr(t_addr a);
+   Returns the scope of the code at address 'a', or 0 if it could not be found.
+*/
+p_scope
+get_scope_from_addr(a)
+  t_addr a;
+{
+  t_scope sc;
+
+  sc.sc_start = a;
+  return (p_scope) find_ngt(ScopeTree, (char *) &sc);
+}
+
+/* extern p_scope	get_next_scope_from_addr(t_addr a);
+   Returns the scope following the one of the code at address 'a',
+   and that has an activation record,
+   or 0 if it could not be found.
+*/
+p_scope
+get_next_scope_from_addr(a)
+  t_addr a;
+{
+  t_scope sc;
+
+  sc.sc_start = a;
+  for (;;) {
+  	p_scope psc = (p_scope) find_nlt(ScopeTree, (char *) &sc);
+	if (! psc || psc->sc_has_activation_record) return psc;
+	sc.sc_start = psc->sc_start+1;
+  }
+  /*NOTREACHED*/
+}
+
+/* extern int	has_static_link(p_scope sc);
+   Returns 1 if the procedure of this scope takes a static link.
+*/
+int
+has_static_link(sc)
+  register p_scope	sc;
+{
+  return sc->sc_proclevel > 1;
+}
+
+/* extern p_scope	base_scope(p_scope sc);
+   Returns the closest enclosing scope of 'sc' that has an activation record.
+*/
+p_scope
+base_scope(sc)
+  register p_scope	sc;
+{
+  while (sc && ! sc->sc_has_activation_record) {
+	sc = sc->sc_static_encl;
+  }
+  return sc;
+}

util/grind/scope.h

@@ -0,0 +1,54 @@
+/* scope structure */
+
+/* $Header$ */
+
+typedef struct scope {
+  struct scope	*sc_static_encl;	/* linked list of enclosing scopes */
+  struct symbol *sc_symbs;		/* symbols defined in this scope */
+  struct symbol *sc_definedby;		/* symbol defining this scope */
+  long		sc_start;		/* start address of code of this scope */
+  long		sc_bp_opp;		/* first breakpoint opportunity */
+  short		sc_proclevel;		/* proc level of this scope */
+  char		sc_has_activation_record;
+} t_scope, *p_scope;
+
+extern p_scope PervasiveScope, CurrentScope, FileScope;
+
+/* extern	init_scope();
+   Initializes the scope routines.
+*/
+extern	init_scope();
+
+/* extern	open_scope(struct symbol *name, int has_activation);
+   Opens a new scope and assigns it to CurrentScope; The new scope is defined
+   by 'name' and if 'has_activation' is set, it has an activation record.
+*/
+extern	open_scope();
+
+/* extern	close_scope();
+   Closes the current scope; CurrentScope becomes the statically enclosing
+   scope.
+*/
+extern	close_scope();
+
+/* extern	add_scope_addr(p_scope sc);
+   Adds scope 'sc' to the list of scopes that have an address at runtime.
+*/
+extern	add_scope_addr();
+
+/* extern p_scope	get_scope_from_addr(t_addr a);
+   Returns the scope of the code at address 'a', or 0 if it could not be found.
+*/
+extern p_scope	get_scope_from_addr();
+
+/* extern p_scope	get_next_scope_from_addr(t_addr a);
+   Returns the scope following the one of the code at address 'a',
+   and that has an activation record,
+   or 0 if it could not be found.
+*/
+extern p_scope	get_next_scope_from_addr();
+
+/* extern p_scope	base_scope(p_scope sc);
+   Returns the closest enclosing scope of 'sc' that has an activation record.
+*/
+extern p_scope	base_scope();

util/grind/sizes.h

@@ -0,0 +1,8 @@
+/* For the time being ... */
+
+#define SZ_INT		4
+#define SZ_SHORT	2
+#define SZ_POINTER	4
+#define SZ_LONG		4
+#define SZ_FLOAT	4
+#define SZ_DOUBLE	8

util/grind/symbol.c

@@ -0,0 +1,237 @@
+/* $Header$ */
+
+/* Symbol handling */
+
+#include	<alloc.h>
+#include	<out.h>
+#include	<stb.h>
+#include	<assert.h>
+
+#include	"position.h"
+#include	"file.h"
+#include	"idf.h"
+#include	"type.h"
+#include	"symbol.h"
+#include	"scope.h"
+#include	"tree.h"
+#include	"operator.h"
+
+p_symbol	currfile;
+
+p_symbol
+NewSymbol(s, scope, class, nam)
+  char	*s;
+  register p_scope scope;
+  struct outname *nam;
+{
+  register p_symbol sym;
+  
+  sym = new_symbol();
+  sym->sy_idf = str2idf(s, 0);
+  sym->sy_scope = scope;
+  sym->sy_prev_sc = scope->sc_symbs;
+  scope->sc_symbs = sym;
+  sym->sy_next = sym->sy_idf->id_def;
+  sym->sy_idf->id_def = sym;
+  sym->sy_class = class;
+  switch(class) {
+  case MODULE:
+  case PROC:
+  case FUNCTION:
+  case VAR:
+  case REGVAR:
+  case LOCVAR:
+  case VARPAR:
+	sym->sy_name.nm_value = nam->on_valu;
+	break;
+  default:
+	break;
+  }
+  return sym;
+}
+
+/* Lookup a definition for 'id' in scope 'scope' with class in the 'class'
+   bitset.
+*/
+p_symbol
+Lookup(id, scope, class)
+  struct idf *id;
+  p_scope scope;
+  int	class;
+{
+  register p_symbol p = id ? id->id_def : 0;
+
+  while (p) {
+	if (p->sy_scope == scope && (p->sy_class & class)) {
+		return p;
+	}
+	p = p->sy_next;
+  }
+  return (p_symbol) 0;
+}
+
+/* Lookup a definition for 'id' with class in the 'class' bitset,
+   starting in scope 'sc' and also looking in enclosing scopes.
+*/
+p_symbol
+Lookfromscope(id, class, sc)
+  register struct idf *id;
+  int	class;
+  register p_scope	sc;
+{
+  if (! id) return (p_symbol) 0;
+
+  while (sc) {
+	register p_symbol sym = id->id_def;
+	while (sym) {
+		if (sym->sy_scope == sc && (sym->sy_class & class)) {
+			return sym;
+		}
+		sym = sym->sy_next;
+	}
+	sc = sc->sc_static_encl;
+  }
+  return (p_symbol) 0;
+}
+
+/* Lookup a definition for 'id' with class in the 'class' bitset,
+   starting in scope 'CurrentScope' and also looking in enclosing scopes.
+*/
+p_symbol
+Lookfor(id, class)
+  register struct idf *id;
+  int	class;
+{
+  return Lookfromscope(id, class, CurrentScope);
+}
+
+extern char *strrindex();
+
+p_symbol
+add_file(s)
+  char	*s;
+{
+  register p_symbol sym = NewSymbol(s,
+				    PervasiveScope,
+				    FILESYM,
+				    (struct outname *) 0);
+  register char *p;
+
+  sym->sy_file = new_file();
+  sym->sy_file->f_sym = sym;
+  p = strrindex(s, '.');
+  if (p) {
+	char c = *p;
+	p_symbol sym1;
+
+	*p = 0;
+	sym1 = NewSymbol(Salloc(s, (unsigned) strlen(s)+1),
+		  	 PervasiveScope,
+		 	 FILELINK,
+			 (struct outname *) 0);
+	*p = c;
+	sym1->sy_filelink = sym;
+  }
+  return sym;
+}
+
+/* Determine if the OP_SELECT tree indicated by 'p' could lead to scope 'sc'.
+*/
+static int
+consistent(p, sc)
+  p_tree	p;
+  p_scope	sc;
+{
+  p_tree	arg;
+  p_symbol	sym;
+
+  assert(p->t_oper == OP_SELECT);
+  sc = sc->sc_static_encl;
+  if (!sc) return 0;
+
+  p = p->t_args[0];
+
+  switch(p->t_oper) {
+  case OP_NAME:
+	sym = Lookfromscope(p->t_idf, FILELINK|FILESYM|PROC|MODULE, sc);
+	return sym != 0;
+
+  case OP_SELECT:
+	arg = p->t_args[1];
+	sym = Lookfromscope(arg->t_idf, FILELINK|FILESYM|PROC|MODULE, sc);
+	if (sym == 0) return 0;
+	return consistent(p, sym->sy_scope);
+
+  default:
+	assert(0);
+  }
+  return 0;	/* notreached? */
+}
+
+/* Try to find the name referred to in the node indicated by 'p', and
+   try to be just a little bit intelligent about it.
+*/
+p_symbol
+identify(p, class_set)
+  p_tree	p;
+  int		class_set;
+{
+  p_symbol	sym = 0;
+  register p_symbol s;
+  p_tree	arg;
+
+  switch(p->t_oper) {
+  case OP_NAME:
+	if (! p->t_sc) p->t_sc = CurrentScope;
+	sym = Lookfromscope(p->t_idf, class_set, p->t_sc);
+	if (sym) {
+		/* Found it. */
+		break;
+	}
+
+	/* We could not find it using scope p->t_sc; now we try to identify
+	   it using class_set. If this results in only one definition, we
+	   take this one.
+	*/
+	s = p->t_idf->id_def;
+	while (s) {
+		if (s->sy_class & class_set) {
+			if (sym) {
+				error("could not identify \"%s\"", p->t_str);
+				sym = 0;
+				break;
+			}
+			sym = s;
+		}
+		s = s->sy_next;
+	}
+	if (!sym && !s) {
+		error("could not find \"%s\"", p->t_str);
+	}
+	break;
+
+  case OP_SELECT:
+	arg = p->t_args[1];
+	assert(arg->t_oper == OP_NAME);
+	s = arg->t_idf->id_def;
+	sym = 0;
+	while (s) {
+		if ((s->sy_class & class_set) && consistent(p, s->sy_scope)) {
+			if (sym) {
+				error("could not identify \"%s\"", arg->t_str);
+				sym = 0;
+			}
+			sym = s;
+		}
+		s = s->sy_next;
+	}
+	if (!sym && !s) {
+		error("could not find \"%s\"", arg->t_str);
+	}
+	break;
+
+  default:
+	assert(0);
+  }
+  return sym;
+}

util/grind/symbol.hh

@@ -0,0 +1,58 @@
+/* $Header$
+   Symbol table data structure.
+   Each identifier structure refers to a list of possible meanings of this
+   identifier. Each of these meanings is represented by a "symbol" structure.
+*/
+
+typedef union constant {	/* depends on type */
+  long	co_ival;
+  double co_rval;
+  char *co_sval;
+  char *co_setval;
+} t_const, *p_const;
+
+typedef struct name {
+  long	nm_value;		/* address or offset */
+  struct scope *nm_scope;	/* for names that define a scope */
+} t_name, *p_name;
+
+typedef struct symbol {
+  struct symbol	*sy_next;	/* link to next meaning */
+  struct symbol	*sy_prev_sc;	/* link to previous decl in scope */
+  struct type	*sy_type;	/* type of symbol */
+  int		sy_class;
+#define CONST		0x0001
+#define TYPE		0x0002
+#define TAG		0x0004
+#define MODULE		0x0008
+#define PROC		0x0010
+#define FUNCTION	0x0020
+#define VAR		0x0040
+#define REGVAR		0x0080
+#define LOCVAR		0x0100
+#define VARPAR		0x0200
+/* #define SYMENTRY	0x0400	/* a non-dbx entry */
+#define FILESYM		0x0800	/* a filename */
+#define FILELINK	0x1000	/* a filename without its suffix */
+  struct idf	*sy_idf;	/* reference back to its idf structure */
+  struct scope	*sy_scope;	/* scope in which this symbol resides */
+  union {
+	t_const	syv_const;	/* CONST */
+	t_name	syv_name;
+/*	struct outname syv_onam;	/* for non-dbx entries */
+	struct file *syv_file;		/* for FILESYM */
+	struct symbol *syv_fllink;	/* for FILELINK */
+  }	sy_v;
+#define sy_const	sy_v.syv_const
+#define sy_name		sy_v.syv_name
+#define sy_onam		sy_v.syv_onam
+#define sy_file		sy_v.syv_file
+#define sy_filelink	sy_v.syv_fllink
+} t_symbol, *p_symbol;
+
+/* ALLOCDEF "symbol" 50 */
+
+extern p_symbol	NewSymbol(), Lookup(), Lookfor(), Lookfromscope(), add_file();
+extern p_symbol identify();
+
+extern p_symbol	currfile;

util/grind/tok_tools.amk

@@ -0,0 +1,15 @@
+MAKE_TOKFILE = make.tokfile;
+MAKE_TOKCASE = make.tokcase;
+
+%tool gen_tokens (
+    csrc:	%in  [type = C-src, gen_tokens, persistent];
+    tokfile:	%out [type = LLgen-src]	=> get($csrc, LL-dest);
+    symbols:	%out [type = C-src, b]	=> get($csrc, cc-dest);
+    mktok:	%in  [type = command]	=> $MAKE_TOKFILE;
+    mkcase:	%in  [type = command]	=> $MAKE_TOKCASE;
+)
+{
+    exec($mktok,  stdin => $csrc, stdout => $tokfile);
+    exec($mkcase, stdin => $csrc, stdout => $symbols);
+    echo({$tokfile, 'and', $symbols, 'created'});
+};

util/grind/tokenname.c

@@ -0,0 +1,88 @@
+/*
+ * (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ * See the copyright notice in the ACK home directory, in the file "Copyright".
+ *
+ * Author: Ceriel J.H. Jacobs
+ */
+
+/* T O K E N   D E F I N I T I O N S */
+
+/* $Header$ */
+
+#include	"tokenname.h"
+#include	"Lpars.h"
+#include	"position.h"
+#include	"file.h"
+#include	"idf.h"
+
+/*	To centralize the declaration of %tokens, their presence in this
+	file is taken as their declaration. The Makefile will produce
+	a grammar file (tokenfile.g) from this file. This scheme ensures
+	that all tokens have a printable name.
+	Also, the "token2str.c" file is produced from this file.
+*/
+
+#if 0
+struct tokenname tkspec[] =	{	/* the names of the special tokens */
+	{NAME, "name"},
+	{STRING, "string"},
+	{INTEGER, "number"},
+	{REAL, "real"},
+	{CHAR, "char"},
+	{0, ""}
+};
+#endif
+
+struct tokenname tkidf[] =	{	/* names of the identifier tokens */
+	{LIST, "list"},
+	{XFILE, "file"},
+	{RUN, "run"},
+	{RERUN, "rerun"},
+	{STOP, "stop"},
+	{WHEN, "when"},
+	{AT, "at"},
+	{IN, "in"},
+	{ON, "on"},
+	{IF, "if"},
+	{CONT, "cont"},
+	{STEP, "step"},
+	{NEXT, "next"},
+	{REGS, "regs"},
+	{WHERE, "where"},
+	{STATUS, "status"},
+	{DELETE, "delete"},
+	{PRINT, "print"},
+	{DUMP, "dump"},
+	{RESTORE, "restore"},
+	{TRACE, "trace"},
+	{-1, "quit"},
+	{0, ""}
+};
+
+#if 0
+struct tokenname tkinternal[] = {	/* internal keywords	*/
+	{0, "0"}
+};
+
+struct tokenname tkstandard[] =	{	/* standard identifiers */
+	{0, ""}
+};
+#endif
+
+/* Some routines to handle tokennames */
+
+reserve(resv)
+	register struct tokenname *resv;
+{
+	/*	The names of the tokens described in resv are entered
+		as reserved words.
+	*/
+	register struct idf *p;
+
+	while (resv->tn_symbol)	{
+		p = str2idf(resv->tn_name, 0);
+		if (!p) fatal("out of Memory");
+		p->id_reserved = resv->tn_symbol;
+		resv++;
+	}
+}

util/grind/tokenname.h

@@ -0,0 +1,17 @@
+/*
+ * (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ * See the copyright notice in the ACK home directory, in the file "Copyright".
+ *
+ * Author: Ceriel J.H. Jacobs
+ */
+
+/* T O K E N N A M E   S T R U C T U R E */
+
+/* $Header$ */
+
+struct tokenname	{	/*	Used for defining the name of a
+					token as identified by its symbol
+				*/
+	int tn_symbol;
+	char *tn_name;
+};

util/grind/tree.c

@@ -0,0 +1,594 @@
+/* $Header$ */
+
+#include	<stdio.h>
+#include	<varargs.h>
+#include	<assert.h>
+#include	<alloc.h>
+#include	<out.h>
+
+#include	"operator.h"
+#include	"position.h"
+#include	"file.h"
+#include	"idf.h"
+#include	"tree.h"
+#include	"message.h"
+#include	"scope.h"
+#include	"symbol.h"
+#include	"langdep.h"
+
+extern FILE	*db_out;
+extern t_lineno	currline;
+extern long	pointer_size;
+extern char	*strrindex();
+
+p_tree		run_command;
+
+/*VARARGS1*/
+p_tree
+mknode(va_alist)
+  va_dcl
+{
+  va_list ap;
+  register p_tree p = new_tree();
+
+  va_start(ap);
+  {
+	register int i, na;
+
+	p->t_oper = va_arg(ap, int);
+	switch(p->t_oper) {
+	case OP_NAME:
+		p->t_idf = va_arg(ap, struct idf *);
+		p->t_str = va_arg(ap, char *);
+		break;
+	case OP_INTEGER:
+		p->t_ival = va_arg(ap, long);
+		break;
+	case OP_AT:
+		p->t_lino = va_arg(ap, long);
+		p->t_filename = va_arg(ap, char *);
+		break;
+	case OP_NEXT:
+	case OP_STEP:
+	case OP_REGS:
+	case OP_DELETE:
+	case OP_RESTORE:
+		p->t_ival = va_arg(ap, long);
+		break;
+	default:
+		na = nargs(p->t_oper);
+		assert(na <= MAXARGS);
+		for (i = 0; i < na; i++) {
+			p->t_args[i] = va_arg(ap, p_tree);
+		}
+		break;
+	}
+  }
+  va_end(ap);
+  return p;
+}
+
+freenode(p)
+  register p_tree	p;
+{
+  register int na, i;
+
+  if (! p) return;
+  switch(p->t_oper) {
+  case OP_NAME:
+  case OP_INTEGER:
+  case OP_AT:
+  case OP_CONT:
+  case OP_NEXT:
+  case OP_STEP:
+  case OP_REGS:
+  case OP_DELETE:
+	break;
+  default:
+	na = nargs(p->t_oper);
+	assert(na <= MAXARGS);
+	for (i = 0; i < na; i++) {
+		freenode(p->t_args[i]);
+	}
+	break;
+  }
+  free_tree(p);
+}
+
+print_node(p, top_level)
+  register p_tree	p;
+{
+  if (!p) return;
+  switch(p->t_oper) {
+  case OP_LIST:
+	fputs("list ", db_out);
+	if (p->t_args[0]) {
+		print_node(p->t_args[0], 0);
+		if (p->t_args[1]) {
+			fputs(", ", db_out);
+			print_node(p->t_args[1], 0);
+		}
+	}
+	break;
+  case OP_PRINT:
+	fputs("print ", db_out);
+	print_node(p->t_args[0], 0);
+	break;
+  case OP_FILE:
+	fputs("file ", db_out);
+	print_node(p->t_args[0], 0);
+	break;
+  case OP_DELETE:
+	fprintf(db_out, "delete %d", p->t_ival);
+	break;
+  case OP_REGS:
+	fprintf(db_out, "regs %d", p->t_ival);
+	break;
+  case OP_NEXT:
+	fprintf(db_out, "next %d", p->t_ival);
+	break;
+  case OP_STEP:
+	fprintf(db_out, "step %d", p->t_ival);
+	break;
+  case OP_STATUS:
+	fputs("status", db_out);
+	break;
+  case OP_DUMP:
+	fputs("dump ", db_out);
+	print_position(p->t_address, 1);
+	break;
+  case OP_RESTORE:
+	fprintf(db_out, "restore %d", p->t_ival);
+	break;
+  case OP_WHERE:
+	fputs("where", db_out);
+	break;
+  case OP_CONT:
+	fputs("cont", db_out);
+	if (p->t_args[0]) {
+		fprintf(db_out, " %d", p->t_args[0]->t_ival);
+	}
+	if (p->t_args[1]) {
+		fputs(" ", db_out);
+		print_node(p->t_args[1], 0);
+	}
+	break;
+
+  case OP_WHEN:
+	fputs("when ", db_out);
+	if (p->t_address != NO_ADDR) {
+		print_position(p->t_address, 1);
+	}
+	else print_node(p->t_args[0], 0);
+	if (p->t_args[1]) {
+		fputs(" if ", db_out);
+		print_node(p->t_args[1], 0);
+	}
+	p = p->t_args[2];
+	fputs(" { ", db_out);
+	while (p->t_oper == OP_LINK) {
+		print_node(p->t_args[0], 0);
+		fputs("; ", db_out);
+		p = p->t_args[1];
+	}
+	print_node(p, 0);
+	fputs(" }", db_out);
+	break;
+  case OP_STOP:
+	fputs("stop ", db_out);
+	if (p->t_address != NO_ADDR) {
+		print_position(p->t_address, 1);
+	}
+	else print_node(p->t_args[0], 0);
+	if (p->t_args[1]) {
+		fputs(" if ", db_out);
+		print_node(p->t_args[1], 0);
+	}
+	break;
+  case OP_TRACE:
+	fputs("trace ", db_out);
+	if (p->t_args[2]) {
+		fputs("on ", db_out);
+		print_node(p->t_args[2], 0);
+		fputs(" ", db_out);
+	}
+	if (p->t_address != NO_ADDR) {
+		print_position(p->t_address, 1);
+	}
+	else print_node(p->t_args[0], 0);
+	if (p->t_args[1]) {
+		fputs(" if ", db_out);
+		print_node(p->t_args[1], 0);
+	}
+	break;
+  case OP_AT:
+	fprintf(db_out, "at \"%s\":%ld", p->t_filename, p->t_lino);
+	break;
+  case OP_IN:
+	fputs("in ", db_out);
+	print_node(p->t_args[0], 0);
+	break;
+  case OP_SELECT:
+	print_node(p->t_args[0], 0);
+	fputs("`", db_out);
+	print_node(p->t_args[1], 0);
+	break;
+  case OP_NAME:
+	fputs(p->t_str, db_out);
+	break;
+  case OP_INTEGER:
+	fprintf(db_out, "%d", p->t_ival);
+	break;
+  }
+  if (top_level) fputs("\n", db_out);
+}
+
+int
+repeatable(com)
+  p_tree	com;
+{
+  switch(com->t_oper) {
+  case OP_CONT:
+  case OP_NEXT:
+  case OP_STEP:
+  case OP_LIST:
+  case OP_STATUS:
+  case OP_PRINT:
+	return 1;
+  }
+  return 0;
+}
+
+int
+in_status(com)
+  p_tree	com;
+{
+  switch(com->t_oper) {
+  case OP_STOP:
+  case OP_WHEN:
+  case OP_TRACE:
+  case OP_DUMP:
+	return 1;
+  }
+  return 0;
+}
+
+eval(p)
+  p_tree	p;
+{
+  if (p) (*operators[p->t_oper].op_fun)(p);
+}
+
+do_list(p)
+  p_tree	p;
+{
+  if (currfile) {
+	lines(currfile->sy_file,
+	      p->t_args[0] ? (int) p->t_args[0]->t_ival : (int) currline,
+	      p->t_args[1] ? (int) p->t_args[1]->t_ival : (int) currline+9);
+	currline = p->t_args[1] ? p->t_args[1]->t_ival + 1 : currline + 10;
+  }
+  else fprintf(db_out, "no current file\n");
+}
+
+do_file(p)
+  p_tree	p;
+{
+  if (p->t_args[0]) {
+	newfile(p->t_args[0]->t_idf);
+  }
+  else if (currfile) fprintf(db_out, "%s\n", currfile->sy_idf->id_text);
+  else fprintf(db_out, "no current file\n");
+}
+
+newfile(id)
+  register struct idf	*id;
+{
+  register p_symbol sym = Lookup(id, PervasiveScope, FILESYM);
+
+  if (currfile != sym) currline = 1;
+  currfile = sym;
+  if (! currfile) {
+	currline = 1;
+	currfile = add_file(id->id_text);
+	currfile->sy_file->f_scope = FileScope;
+  }
+  find_language(strrindex(id->id_text, '.'));
+}
+
+static t_addr
+get_pos(p)
+  p_tree	p;
+{
+  t_addr	a = ILL_ADDR;
+  register p_symbol sym;
+
+  if (! p) return NO_ADDR;
+  if (p->t_address != 0) return p->t_address;
+  switch(p->t_oper) {
+  case OP_AT:
+	if (! p->t_filename &&
+	    (! currfile || ! (p->t_filename = currfile->sy_idf->id_text))) {
+		error("no current file");
+		break;
+	}
+	a = get_addr_from_position(&(p->t_pos));
+	if (a == ILL_ADDR) {
+		error("could not determine address of \"%s\":%d",
+			p->t_filename, p->t_lino);
+		break;
+	}
+	p->t_address = a;
+	break;
+	
+  case OP_IN:
+	a =  get_pos(p->t_args[0]);
+	p->t_address = a;
+	break;
+
+  case OP_NAME:
+  case OP_SELECT:
+	sym = identify(p, PROC|MODULE);
+	if (! sym) {
+		break;
+	}
+	if (! sym->sy_name.nm_scope || ! sym->sy_name.nm_scope->sc_bp_opp) {
+		error("could not determine address of \"%s\"", p->t_str);
+		break;
+	}
+	a = sym->sy_name.nm_scope->sc_bp_opp;
+	break;
+
+  default:
+	assert(0);
+  }
+  return a;
+}
+
+do_stop(p)
+  p_tree	p;
+{
+  t_addr	a = get_pos(p->t_args[0]);
+
+  if (a == ILL_ADDR) {
+	return;
+  }
+
+  p->t_address = a;
+  add_to_item_list(p);
+  if (a != NO_ADDR) {
+	if (! set_or_clear_breakpoint(a, SETBP)) {
+		error("could not set breakpoint");
+	}
+  }
+}
+
+do_trace(p)
+  p_tree	p;
+{
+  t_addr a;
+  t_addr e;
+
+  p->t_address = NO_ADDR;
+  if (p->t_args[0]) {
+	a = get_pos(p->t_args[0]);
+	if (a == ILL_ADDR) return;
+	if (p->t_args[0]->t_oper == OP_AT) {
+		e = a;
+		p->t_address = a;
+	}
+	else {
+		p_scope sc = get_next_scope_from_addr(a+1);
+
+		if (sc) e = sc->sc_start - 1;
+		else e = 0xffffffff;
+	}
+	if (! set_or_clear_trace(a, e, SETTRACE)) {
+		error("could not set trace");
+	}
+  }
+  add_to_item_list(p);
+}
+
+do_continue(p)
+  p_tree	p;
+{
+  int count;
+
+  if (p) {
+	count = p->t_args[0]->t_ival;
+	if (p->t_args[1]) {
+		t_addr	a = get_addr_from_position(&(p->t_args[1]->t_pos));
+		p_scope sc = get_scope_from_addr(a);
+
+		if (a == ILL_ADDR || base_scope(sc) != base_scope(CurrentScope) ||
+		    ! set_pc(a)) {
+			error("cannot continue at line %d",
+			      p->t_args[1]->t_lino);
+			return;
+		}
+	}
+  }
+  else count = 1;
+  while (count--) {
+	if (! send_cont(count==0)) {
+		error("no debuggee");
+		break;
+	}
+  }
+}
+
+do_step(p)
+  p_tree	p;
+{
+  if (! do_single_step(SETSS, p->t_ival)) {
+	error("no debuggee");
+  }
+}
+
+do_next(p)
+  p_tree	p;
+{
+
+  if (! do_single_step(SETSSF, p->t_ival)) {
+	error("no debuggee");
+  }
+}
+
+extern t_addr	*get_EM_regs();
+
+do_regs(p)
+  p_tree	p;
+{
+  t_addr	*buf;
+  int		n = p->t_ival;
+
+  if (! (buf = get_EM_regs(n))) {
+	error("no debuggee");
+	return;
+  }
+  fprintf(db_out, "EM registers %d levels back:\n", n);
+  fprintf(db_out, "\tLocalBase =\t0x%lx\n\tArgumentBase =\t0x%lx\n", 
+		(long) buf[LB_OFF], (long) buf[AB_OFF]);
+  fprintf(db_out, "\tProgramCounter=\t0x%lx\n\tHeapPointer = \t0x%lx\n",
+		(long) buf[PC_OFF],
+		(long) buf[HP_OFF]);
+  fprintf(db_out, "\tStackPointer =\t0x%lx\n", (long) buf[SP_OFF]);
+}
+
+/*ARGSUSED*/
+do_where(p)
+  p_tree	p;
+{
+  int i = 0;
+
+  for (;;) {
+	t_addr AB;
+	t_addr PC;
+	p_scope sc;
+	t_addr *buf;
+
+	if (! (buf = get_EM_regs(i++))) {
+		error("no debuggee");
+		return;
+	}
+	AB = buf[AB_OFF];
+	PC = buf[PC_OFF];
+	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);
+  }
+}
+
+/*ARGSUSED*/
+do_status(p)
+  p_tree	p;
+{
+  print_items();
+}
+
+extern p_tree	remove_from_item_list();
+
+do_delete(p)
+  p_tree	p;
+{
+  p = remove_from_item_list((int) p->t_ival);
+
+  if (p) switch(p->t_oper) {
+  case OP_WHEN:
+  case OP_STOP: {
+	t_addr a = get_pos(p->t_args[0]);
+
+	if (a != ILL_ADDR && a != NO_ADDR) {
+		set_or_clear_breakpoint(a, CLRBP);
+	}
+	break;
+	}
+  case OP_TRACE: {
+	t_addr a = get_pos(p->t_args[0]);
+	
+	if (a != ILL_ADDR && a != NO_ADDR) {
+		t_addr e;
+		if (p->t_args[0]->t_oper == OP_AT) {
+			e = a;
+		}
+		else {
+			p_scope sc = get_next_scope_from_addr(a+1);
+
+			if (sc) e = sc->sc_start - 1;
+			else e = 0xffffffff;
+		}
+		set_or_clear_trace(a, e, CLRTRACE);
+	}
+	break;
+	}
+  case OP_DUMP:
+	free_dump(p);
+  }
+  freenode(p);
+}
+
+do_print(p)
+  p_tree	p;
+{
+  p_symbol sym;
+
+  switch(p->t_oper) {
+  case OP_PRINT:
+	do_print(p->t_args[0]);
+	break;
+  case OP_LINK:
+	do_print(p->t_args[0]);
+	do_print(p->t_args[1]);
+	break;
+  case OP_NAME:
+  case OP_SELECT:
+	sym = identify(p, VAR|REGVAR|LOCVAR|VARPAR);
+	if (! sym) return;
+	print_node(p, 0);
+	if (! print_sym(sym)) {
+		fputs(" currently not available\n", db_out);
+		break;
+	}
+  }
+}
+
+perform(p, a)
+  register p_tree	p;
+  t_addr		a;
+{
+  switch(p->t_oper) {
+  case OP_WHEN:
+	p = p->t_args[2];
+	while (p->t_oper == OP_LINK) {
+		eval(p->t_args[0]);
+		p = p->t_args[1];
+	}
+	eval(p);
+	break;
+  case OP_TRACE:
+	if (p->t_args[0] && p->t_args[0]->t_oper == OP_IN) {
+		register p_scope sc = base_scope(CurrentScope);
+	
+		if (sc != get_scope_from_addr(p->t_args[0]->t_address)) {
+			break;
+		}
+	}
+	{
+		p_position pos = get_position_from_addr(a);
+
+		newfile(str2idf(pos->filename, 1));
+		currline = pos->lineno;
+		lines(currfile->sy_file, (int)currline, (int)currline);
+		if (p->t_args[2]) do_print(p->t_args[2]);
+	}
+	break;
+  default:
+	assert(0);
+  }
+}

util/grind/tree.hh

@@ -0,0 +1,32 @@
+/* $Header$ */
+
+#define MAXARGS	3
+
+typedef struct tree {
+  int	t_oper;		/* operator */
+  t_addr t_address;	/* some operators use an address */
+  int	t_itemno;	/* item number in status list */
+  union {
+	long tt_ival;
+	struct {
+		struct idf *tt_idf;
+		char *tt_str;
+		struct scope *tt_scope;	
+	} tt_x;
+	struct tree *tt_args[MAXARGS];
+	t_position tt_pos;
+  } t_xxxx;
+#define t_ival	t_xxxx.tt_ival
+#define t_idf	t_xxxx.tt_x.tt_idf
+#define t_str	t_xxxx.tt_x.tt_str
+#define t_sc	t_xxxx.tt_x.tt_scope
+#define t_args	t_xxxx.tt_args
+#define t_lino t_xxxx.tt_pos.lineno
+#define t_filename t_xxxx.tt_pos.filename
+#define t_pos	t_xxxx.tt_pos
+} t_tree, *p_tree;
+
+/* ALLOCDEF "tree" 100 */
+
+extern p_tree	mknode();
+extern p_tree	run_command;

util/grind/type.c

@@ -0,0 +1,387 @@
+/* $Header$ */
+
+/* Routines to create type structures */
+
+#include <alloc.h>
+#include <assert.h>
+
+#include "type.h"
+#include "sizes.h"
+#include "symbol.h"
+#include "scope.h"
+#include "message.h"
+#include "langdep.h"
+
+p_type	int_type, char_type, short_type, long_type;
+p_type	uint_type, uchar_type, ushort_type, ulong_type;
+p_type	void_type, incomplete_type;
+p_type	float_type, double_type;
+p_type	string_type;
+
+long	int_size = SZ_INT,
+	char_size = 1,
+	short_size = SZ_SHORT,
+	long_size = SZ_LONG,
+	pointer_size = SZ_POINTER;
+
+long	float_size = SZ_FLOAT,
+	double_size = SZ_DOUBLE;
+
+struct bounds {
+	long low, high;
+};
+
+static struct bounds ibounds[2] = {
+	{ -128, 127 },
+	{ -32768, 32767 }
+};
+
+static struct bounds ubounds[2] = {
+	{ 0, 255 },
+	{ 0, 65535 }
+};
+
+static long max_int[8], max_uns[8];
+
+struct integer_types {
+	long	maxval;
+	p_type	type;
+};
+
+static struct integer_types i_types[4];
+static struct integer_types u_types[5];
+
+#define ufit(n, nb)	Xfit(n, nb, ubounds)
+#define ifit(n, nb)	Xfit(n, nb, ibounds)
+#define Xfit(n, nb, b)	((n) >= (b)[(nb)-1].low && (n) <= (b)[(nb)-1].high)
+
+/* Create a subrange type, but is it really a subrange? */
+p_type
+subrange_type(A, base_index, c1, c2, result_index)
+  int *base_index, *result_index;
+  long c1, c2;
+{
+  int itself = 0;
+  register p_type p;
+  p_type base_type;
+
+  if (!A) {
+	/* Subrange of itself is a special case ... */
+	if (result_index &&
+ 	   result_index[0] == base_index[0] &&
+ 	   result_index[1] == base_index[1]) {
+
+		/* c1 = 0 and c2 = 0 -> void */
+		if (c1 == 0 && c2 == 0) {
+			return void_type;
+		}
+
+		/* c1 = 0 and c2 = 127 -> char ??? */
+		if (c1 == 0 && c2 == 127) {
+			return char_type;
+		}
+		itself = 1;
+	}
+  }
+
+  if (itself) base_type = int_type; else base_type = *(tp_lookup(base_index));
+
+  if (! A) {
+	/* c2 = 0 and c1 > 0 -> real */
+	if (c2 == 0 && c1 > 0) {
+		if (c1 == float_size) return float_type;
+		return double_type;
+	}
+
+	/* c1 = 0 and base_index indicates int_type or itself -> unsigned,
+	   c1 = -c2 - 1 and base_index indicates int_type or itself -> integer
+	*/
+	if (itself || base_type == int_type) {
+		register struct integer_types *ip = 0;
+		if (c1 == 0) {
+			ip = &u_types[0];
+		}
+		else if (c1 == -c2 - 1) {
+			ip = &i_types[0];
+		}
+		if (ip) {
+			while (ip->maxval != 0 && ip->maxval != c2) ip++;
+			if (ip->maxval) return ip->type;
+		}
+	}
+  }
+  /* if we get here, it actually is a subrange type */
+  p = new_type();
+  p->ty_class = T_SUBRANGE;
+  p->ty_low = c1;
+  p->ty_up = c2;
+  p->ty_base = base_type;
+  p->ty_A = A;
+
+  /* determine size of subrange type */
+  p->ty_size = base_type->ty_size;
+  if (!A && p->ty_base == uint_type) {
+  	if (ufit(p->ty_up, 1)) {
+		p->ty_size = 1;
+  	}
+  	else if (ufit(p->ty_up, (int)short_size)) {
+		p->ty_size = short_size;
+	}
+  }
+  if (!A && p->ty_base == int_type) {
+  	if (ifit(p->ty_up, 1) && ifit(p->ty_low, 1)) {
+		p->ty_size = 1;
+  	}
+  	else if (ifit(p->ty_up, (int)short_size) &&
+		 ifit(p->ty_low, (int)short_size)) {
+		p->ty_size = short_size;
+	}
+  }
+
+  return p;
+}
+
+static long
+nel(tp)
+  register p_type tp;
+{
+  switch(tp->ty_class) {
+  case T_SUBRANGE:
+	if (tp->ty_A) return 0;
+	if (tp->ty_low <= tp->ty_up) return tp->ty_up - tp->ty_low + 1;
+	return tp->ty_low - tp->ty_up + 1;
+  case T_UNSIGNED:
+  case T_INTEGER:
+	if (tp->ty_size == 1) return 256;
+	if (tp->ty_size == 2) return 65536L;
+	assert(0);
+	break;
+  case T_ENUM:
+	return tp->ty_nenums;
+  default:
+	assert(0);
+	break;
+  }
+  return 0;
+}
+
+p_type
+array_type(bound_type, el_type)
+  p_type bound_type, el_type;
+{
+  register p_type tp = new_type();
+
+  tp->ty_class = T_ARRAY;
+  tp->ty_index = bound_type;
+  tp->ty_elements = el_type;
+  tp->ty_size = (*currlang->arrayelsize)(el_type->ty_size) * nel(bound_type);
+  return tp;
+}
+
+p_type
+basic_type(fund, size)
+  int	fund;
+  long	size;
+{
+  register p_type	p = new_type();
+
+  p->ty_class = fund;
+  p->ty_size = size;
+  return p;
+}
+
+set_bounds(tp)
+  register p_type	tp;
+{
+  /* Determine the size and low of a set type */
+  register p_type base = tp->ty_setbase;
+
+  if (base->ty_class == T_SUBRANGE) {
+	tp->ty_size = (base->ty_up - base->ty_low + 7) >> 3;
+	tp->ty_setlow = base->ty_low;
+  }
+  else if (base->ty_class == T_INTEGER) {
+	tp->ty_size = (max_int[(int)base->ty_size] + 1) >>  2;
+	tp->ty_setlow = -max_int[(int)base->ty_size] - 1;
+  }
+  else {
+	assert(base->ty_class == T_UNSIGNED);
+	tp->ty_size = (max_uns[(int)base->ty_size] + 1) >>  3;
+	tp->ty_setlow = 0;
+  }
+}
+
+init_types()
+{
+  register int i = 0;
+  register long x = 0;
+
+  while (x >= 0) {
+	i++;
+	x = (x << 8) + 0377;
+	max_uns[i] = x;
+	max_int[i] = x & ~(1L << (8*i - 1));
+  }
+  int_type = basic_type(T_INTEGER, int_size);
+  long_type = basic_type(T_INTEGER, long_size);
+  short_type = basic_type(T_INTEGER, short_size);
+  char_type = basic_type(T_INTEGER, char_size);
+  uint_type = basic_type(T_UNSIGNED, int_size);
+  ulong_type = basic_type(T_UNSIGNED, long_size);
+  ushort_type = basic_type(T_UNSIGNED, short_size);
+  uchar_type = basic_type(T_UNSIGNED, char_size);
+  string_type = basic_type(T_STRING, 0L);
+  void_type = basic_type(T_VOID, 0L);
+  incomplete_type = basic_type(T_INCOMPLETE, 0L);
+  float_type = basic_type(T_REAL, float_size);
+  double_type = basic_type(T_REAL, double_size);
+
+  i_types[0].maxval = max_int[(int)int_size]; i_types[0].type = int_type;
+  i_types[1].maxval = max_int[(int)short_size]; i_types[1].type = short_type;
+  i_types[2].maxval = max_int[(int)long_size]; i_types[2].type = long_type;
+  u_types[0].maxval = max_uns[(int)int_size]; u_types[0].type = uint_type;
+  u_types[1].maxval = max_uns[(int)short_size]; u_types[1].type = ushort_type;
+  u_types[2].maxval = max_uns[(int)long_size]; u_types[2].type = ulong_type;
+  u_types[3].maxval = max_uns[1]; u_types[3].type = uchar_type;
+}
+
+/*
+ * Some code to handle type indices, which are pairs of integers.
+ * What we need is a two-dimensional array, but we don't know how large
+ * it is going to be, so we use a list of rows instead.
+ */
+static struct tp_index {
+  unsigned	len;
+  p_type	*row;
+} *list_row;
+static unsigned list_len;
+
+#define NINCR 10
+  
+p_type *
+tp_lookup(type_index)
+  int *type_index;
+{
+  register int i;
+  register struct tp_index *p;
+
+  while (type_index[0] >= list_len) {
+	if (list_len) {
+		list_row = (struct tp_index *) Realloc((char *) list_row,
+				(list_len += NINCR) * sizeof(struct tp_index));
+	}
+	else	list_row = (struct tp_index *)
+			Malloc((list_len = NINCR) * sizeof(struct tp_index));
+	for (i = NINCR; i > 0; i--) {
+		list_row[list_len - i].len = 0;
+	}
+  }
+  p = &list_row[type_index[0]];
+  while (type_index[1] >= p->len) {
+	if (p->len) {
+		p->row = (p_type *) Realloc((char *) p->row,
+				(p->len += NINCR) * sizeof(p_type));
+	}
+	else	p->row = (p_type *) Malloc((p->len = NINCR) * sizeof(p_type));
+	for (i = NINCR; i > 0; i--) {
+		p->row[p->len - i] = 0;
+	}
+  }
+  return &(p->row[type_index[1]]);
+}
+
+clean_tp_tab()
+{
+  if (list_len) {
+  	register int i = list_len;
+
+  	while (--i >= 0) {
+		register int j = list_row[i].len;
+		if (j) {
+			while (--j > 0) {
+				p_type p = list_row[i].row[j];
+				if (p == incomplete_type) {
+					error("incomplete type (%d,%d) 0x%x", i, j, &list_row[i].row[j]);
+				}
+			}
+			free((char *) list_row[i].row);
+		}
+	}
+	free((char *) list_row);
+	list_len = 0;
+	list_row = 0;
+  }
+}
+
+end_literal(tp, maxval)
+  register p_type tp;
+  long maxval;
+{
+  tp->ty_literals = (struct literal *)
+	Realloc((char *) tp->ty_literals,
+		tp->ty_nenums * sizeof(struct literal));
+  if (ufit(maxval, 1)) tp->ty_size = 1;
+  else if (ufit(maxval, (int)short_size)) tp->ty_size = short_size;
+  else tp->ty_size = int_size;
+}
+
+long
+param_size(t, v)
+  int	v;
+  p_type t;
+{
+  if (v == 'i' || v == 'v') {
+	/* addresss; only exception is a conformant array, which also
+	   takes a descriptor.
+	*/
+	if (t->ty_class == T_ARRAY &&
+	    t->ty_index->ty_class == T_SUBRANGE &&
+	    t->ty_index->ty_A) {
+		return pointer_size + 3 * int_size;
+	}
+	return pointer_size;
+  }
+  return ((t->ty_size + int_size - 1) / int_size) * int_size;
+}
+
+add_param_type(v, s)
+  int	v;		/* 'v' or 'i' for address, 'p' for value */
+  p_symbol s;		/* parameter itself */
+{
+  register p_scope sc = base_scope(s->sy_scope);
+  register p_type prc_type;
+
+  if (! sc) return;
+  prc_type = sc->sc_definedby->sy_type;
+  assert(prc_type->ty_class == T_PROCEDURE);
+
+  prc_type->ty_nparams++;
+  prc_type->ty_params = (struct param *) Realloc((char *) prc_type->ty_params, 
+				(unsigned)prc_type->ty_nparams * sizeof(struct param));
+  prc_type->ty_params[prc_type->ty_nparams - 1].par_type = s->sy_type;
+  prc_type->ty_params[prc_type->ty_nparams - 1].par_kind = v;
+  prc_type->ty_nbparams += param_size(s->sy_type, v);
+}
+
+/* Compute the size of a parameter of dynamic size
+*/
+
+long
+compute_size(tp, AB)
+  p_type	tp;
+  char		*AB;
+{
+  long	low, high;
+
+  assert(tp->ty_class == T_ARRAY);
+  assert(tp->ty_index->ty_class == T_SUBRANGE);
+  assert(tp->ty_index->ty_A != 0);
+
+  if (tp->ty_index->ty_A & 1) {
+	low = BUFTOI(AB+tp->ty_index->ty_low);
+  } else low = tp->ty_index->ty_low;
+  if (tp->ty_index->ty_A & 2) {
+	high = BUFTOI(AB+tp->ty_index->ty_up);
+  } else high = tp->ty_index->ty_up;
+  return (high - low + 1) * tp->ty_elements->ty_size;
+}

util/grind/type.hh

@@ -0,0 +1,118 @@
+/* $Header$ */
+
+/* internal type representation */
+
+/* structure for struct/union elements */
+struct fields {
+  long fld_pos;			/* position of field */
+  long fld_bitsize;		/* size in bits */
+  struct type *fld_type;	/* type of field */
+  char *fld_name;		/* name of field */
+};
+
+/* structure for enumeration literals */
+struct literal {
+  long lit_val;			/* value of literal */
+  char *lit_name;		/* name of literal */
+};
+
+/* structure for parameters */
+struct param {
+  struct type *par_type;	/* type of parameter */
+  char par_kind;		/* kind of parameter ('p', 'i', or 'v') */
+};
+
+typedef struct type {
+  short		ty_class;
+#define T_SUBRANGE	 1
+#define T_ARRAY		 2
+#define T_STRUCT	 3
+#define T_UNION		 4
+#define T_ENUM		 5
+#define T_POINTER	 6
+#define T_FILE		 7
+#define T_PROCEDURE	 8
+#define T_SET		 9
+#define T_REAL		10
+#define T_INTEGER	11
+#define T_VOID		12
+#define T_UNSIGNED	13
+#define T_STRING	14	/* only for string constants ... */
+#define T_INCOMPLETE   100
+  short		ty_flags;
+#define T_CROSS		0x0001
+  long		ty_size;
+  union {
+     /* cross references */
+     char	    *typ_tag;
+#define ty_tag		ty_v.typ_tag
+     /* procedures/functions: */
+     struct {
+	int	    typ_nparams;
+	struct type *typ_retval;
+	struct param *typ_params;
+	long	    typ_nbparams;
+     } ty_proc;
+#define ty_nparams	ty_v.ty_proc.typ_nparams
+#define ty_retval	ty_v.ty_proc.typ_retval
+#define ty_params	ty_v.ty_proc.typ_params
+#define ty_nbparams	ty_v.ty_proc.typ_nbparams
+     /* pointers, files: */
+     struct type *typ_ptrto;
+#define ty_ptrto	ty_v.typ_ptrto
+#define ty_fileof	ty_v.typ_ptrto
+     /* arrays: */
+     struct {
+	struct type *typ_index;
+	struct type *typ_elements;
+     } ty_array;
+#define ty_index	ty_v.ty_array.typ_index
+#define ty_elements	ty_v.ty_array.typ_elements
+     /* subranges: */
+     struct {
+	long typ_low, typ_up;
+	int typ_A;
+	struct type *typ_base;
+     } ty_subrange;
+#define ty_A		ty_v.ty_subrange.typ_A
+#define ty_low		ty_v.ty_subrange.typ_low
+#define ty_up		ty_v.ty_subrange.typ_up
+#define ty_base		ty_v.ty_subrange.typ_base
+     /* structures/unions: */
+     struct {
+	unsigned typ_nfields;		/* number of field structures */
+	struct fields *typ_fields;
+     } ty_struct;
+#define ty_nfields	ty_v.ty_struct.typ_nfields
+#define ty_fields	ty_v.ty_struct.typ_fields
+     /* enumerations: */
+     struct {
+	unsigned typ_nenums;		/* number of enumeration literals */
+	struct literal *typ_literals;
+     } ty_enum;
+#define ty_nenums	ty_v.ty_enum.typ_nenums
+#define ty_literals	ty_v.ty_enum.typ_literals
+     /* bit sets: */
+     struct {
+	struct type *typ_setbase;	/* base type of set elements */
+	long typ_setlow;		/* low bound */
+     } ty_set;
+#define ty_setbase	ty_v.ty_set.typ_setbase
+#define ty_setlow	ty_v.ty_set.typ_setlow
+  } ty_v;
+} t_type, *p_type;
+
+/* ALLOCDEF "type" 50 */
+
+extern p_type
+	subrange_type(),
+	array_type(),
+	*tp_lookup();
+extern long
+	param_size(),
+	compute_size();
+
+extern p_type	char_type, uchar_type,
+		long_type, double_type, string_type;
+extern p_type	void_type, incomplete_type;
+

util/grind/value.c

@@ -0,0 +1,125 @@
+/* $Header$ */
+
+#include <alloc.h>
+
+#include "position.h"
+#include "scope.h"
+#include "symbol.h"
+#include "type.h"
+#include "message.h"
+
+int stack_offset;		/* for up and down commands */
+
+extern long pointer_size;
+extern t_addr *get_EM_regs();
+
+/* Get the value of the symbol indicated by sym.
+   Return 0 on failure,
+	  1 on success.
+   On success, 'buf' contains the value, and 'AB' may contain the parameters
+   of the procedure invocation containing sym.
+   For both of these, storage is allocated by Malloc; this storage must
+   be freed by caller (I don't like this any more than you do, but caller
+   does not know sizes).
+*/
+int
+get_value(sym, buf, AB)
+  register p_symbol	sym;
+  char	**buf, **AB;
+{
+  p_type	tp = sym->sy_type;
+  long		size = tp->ty_size;
+  int		retval = 0;
+  t_addr	*EM_regs;
+  int		i;
+  p_scope	sc, symsc;
+
+  *buf = 0;
+  *AB = 0;
+  switch(sym->sy_class) {
+  case VAR:
+	/* exists if child exists; nm_value contains addres */
+	*buf = Malloc((unsigned) size);
+	if (get_bytes(size, (t_addr) sym->sy_name.nm_value, *buf)) {
+		retval = 1;
+	}
+	break;
+
+  case VARPAR:
+  case LOCVAR:
+	/* first find the stack frame in which it resides */
+	symsc = base_scope(sym->sy_scope);
+
+	/* now symsc contains the scope where the storage for sym is
+	   allocated. Now find it on the stack of child.
+	*/
+	i = stack_offset;
+	for (;;) {
+		sc = 0;
+		if (! (EM_regs = get_EM_regs(i++))) {
+			/* no child? */
+			break;
+		}
+		if (! EM_regs[AB_OFF]) {
+			/* no more frames */
+			break;
+		}
+		sc = base_scope(get_scope_from_addr(EM_regs[PC_OFF]));
+		if (! sc || sc->sc_start > EM_regs[PC_OFF]) {
+			sc = 0;
+			break;
+		}
+		if (sc == symsc) break;		/* found it */
+	}
+
+	if (! sc) break;	/* not found */
+
+	if (sym->sy_class == LOCVAR) {
+		/* Either local variable or value parameter */
+		*buf = Malloc((unsigned) size);
+		if (get_bytes(size,
+			      EM_regs[sym->sy_name.nm_value < 0 
+					? LB_OFF 
+					: AB_OFF
+				     ] +
+				  (t_addr) sym->sy_name.nm_value,
+			      *buf)) {
+			retval = 1;
+		}
+		break;
+	}
+
+	/* If we get here, we have a var parameter. Get the parameters
+	   of the current procedure invocation.
+	*/
+	{
+		p_type proctype = sc->sc_definedby->sy_type;
+
+		size = proctype->ty_nbparams;
+		if (has_static_link(sc)) size += pointer_size;
+		*AB = Malloc((unsigned) size);
+		if (! get_bytes(size, EM_regs[AB_OFF], *AB)) {
+			break;
+		}
+		if ((size = tp->ty_size) == 0) {
+			size = compute_size(tp, *AB);
+		}
+	}
+	*buf = Malloc((unsigned) size);
+	if (get_bytes(size,
+		      (t_addr) BUFTOA(*AB+sym->sy_name.nm_value),
+		      *buf)) {
+		retval = 1;
+	}
+	break;
+  }
+
+  if (retval == 0) {
+	if (*buf) free(*buf);
+	if (*AB) free(*AB);
+	*buf = 0;
+	*AB = 0;
+  }
+
+  return retval;
+}