Added Pascal support

util/grind/Amakefile

@@ -34,6 +34,7 @@ CSRC = {
 	rd.c,
 	do_comm.c,
 	modula-2.c,
+	pascal.c,
 	c.c
 } ;
 

util/grind/char.ct

@@ -65,7 +65,7 @@ STSIMP:-+,!<>{}:`?\\
 %	ISTOKEN
 %
 %C
-1:-acefiprstuvxAEFGLMPQSTVX,;:+=()*
+1:-acefiprstuvxAEFGLMPQSTVXZ,;:+=()*
 %T char istoken[] = {
 %p
 %T};

util/grind/db_symtab.g

@@ -50,6 +50,7 @@ debugger_string
   { register p_symbol s;
     char *str;
     p_type tmp = 0;
+    int upb = 0;
   }
 :
   name(&str)
@@ -150,6 +151,22 @@ debugger_string
 			{ s = NewSymbol(str, CurrentScope, LOCVAR, currnam); }
 	type_name(&(s->sy_type), s)
 
+  | /* lower or upper bound of array descriptor */
+	[ 'A' 		{ upb = LBOUND; }
+	| 'Z'		{ upb = UBOUND; }
+	]
+	[ ['p' | ]	{ s = NewSymbol(str, CurrentScope, LOCVAR, currnam);
+			  if (upb == UBOUND) add_param_type('Z', s);
+			}
+	| [ 'V' | 'S' ]	{ s = NewSymbol(str, CurrentScope, VAR, currnam); }
+	]
+	type_name(&(s->sy_type), s)
+			{ p_symbol s1 = new_symbol();
+			  *s1 = *s;
+			  s->sy_class = upb;
+			  s->sy_descr = s1;
+			}
+
   | /* function result in Pascal; ignore ??? */
 			{ s = NewSymbol(str, CurrentScope, LOCVAR, currnam); }
 	'X' type_name(&(s->sy_type), s)
@@ -367,6 +384,7 @@ type(p_type *ptp; int *type_index; p_symbol sy;)
 	';'
 	[ 'A' integer_const(&ic2)	{ A_used |= 2; }
 	| integer_const(&ic2)
+	| 'Z' integer_const(&ic2)	{ A_used |= 0200; }
 	]
 			{ if (tp != *ptp) free_type(tp);
 			  tp = subrange_type(A_used,
@@ -516,7 +534,8 @@ param_list(p_type t;)
   	|	'i' 	{ p->par_kind = 'i'; }
   	]
   	type(&(p->par_type), (int *) 0, (p_symbol) 0) ';'
-			{ t->ty_nbparams += 
+			{ p->par_off = t->ty_nbparams;
+			  t->ty_nbparams += 
 				param_size(p->par_type, p->par_kind);
 			  p++;
 			}

util/grind/expr.c

@@ -152,6 +152,23 @@ get_addr(sym, psize)
   return 0;
 }
 
+static int
+get_v(a, pbuf, size)
+  t_addr	a;
+  char		**pbuf;
+  long		size;
+{
+  if (a) {
+	*pbuf = malloc((unsigned) size);
+	if (! *pbuf) {
+		error("could not allocate enough memory");
+		return 0;
+	}
+	if (! get_bytes(size, a, *pbuf)) return 0;
+  }
+  return 1;
+}
+
 /* static int	get_value(p_symbol sym; char **pbuf; long *psize);
    Get the value of the symbol indicated by sym.  Return 0 on failure,
    1 on success. On success, 'pbuf' contains the value, and 'psize' contains
@@ -205,17 +222,23 @@ get_value(sym, pbuf, psize)
   case VARPAR:
   case LOCVAR:
 	a = get_addr(sym, psize);
-	if (a) {
-		size = *psize;
-		*pbuf = malloc((unsigned) size);
-		if (! *pbuf) {
-			error("could not allocate enough memory");
-			break;
-		}
-		if (get_bytes(size, a, *pbuf)) {
-			retval = 1;
-		}
-	}
+	retval = get_v(a, pbuf, *psize);
+	size = *psize;
+	break;
+  case UBOUND:
+	a = get_addr(sym->sy_descr, psize);
+	retval = get_v(a, pbuf, *psize);
+	if (! retval) break;
+	size = get_int(*pbuf, *psize, T_INTEGER);
+	retval = get_v(a+*psize, pbuf, *psize);
+	if (! retval) break;
+	size += get_int(*pbuf, *psize, T_INTEGER);
+	put_int(*pbuf, *psize, size);
+	size = *psize;
+	break;
+  case LBOUND:
+	a = get_addr(sym->sy_descr, psize);
+	retval = get_v(a, pbuf, *psize);
 	break;
   }
 
@@ -1278,7 +1301,7 @@ eval_expr(p, pbuf, psize, ptp)
 	break;
   case OP_NAME:
   case OP_SELECT:
-	sym = identify(p, VAR|REGVAR|LOCVAR|VARPAR|CONST);
+	sym = identify(p, VAR|REGVAR|LOCVAR|VARPAR|CONST|LBOUND|UBOUND);
 	if (! sym) return 0;
 	if (! get_value(sym, pbuf, psize)) {
 		break;

util/grind/langdep.cc

@@ -29,6 +29,7 @@ add_language(suff, lang)
 
 init_languages()
 {
+  add_language(".p", pascal_dep);
   add_language(".mod", m2_dep);
   add_language(".c", c_dep);
 }

util/grind/langdep.h

@@ -36,7 +36,7 @@ struct langdep {
   int	(*fix_bin_to_pref)();
 };
 
-extern struct langdep	*m2_dep, *c_dep, *currlang;
+extern struct langdep	*m2_dep, *c_dep, *pascal_dep, *currlang;
 
 extern int find_language();
 

util/grind/pascal.c

@@ -0,0 +1,479 @@
+/* $Header$ */
+
+/* Language dependant support; this one is for Pascal */
+
+#include <stdio.h>
+#include <alloc.h>
+#include <assert.h>
+#include <ctype.h>
+
+#include "position.h"
+#include "class.h"
+#include "langdep.h"
+#include "Lpars.h"
+#include "idf.h"
+#include "token.h"
+#include "expr.h"
+#include "tree.h"
+#include "operator.h"
+
+extern FILE *db_out, *db_in;
+
+extern double
+	atof();
+
+extern long
+	atol();
+
+static int
+	print_string(),
+	print_char(),
+	get_number(),
+	getname(),
+	get_token(),
+	getstring(),
+	print_op(),
+	binop_prio(),
+	unop_prio(),
+	fix_bin_to_pref();
+
+static long
+	array_elsize();
+
+static struct langdep pascal = {
+	1,
+
+	"%ld",
+	"0%lo",
+	"0x%lx",
+	"%lu",
+	"0x%lx",
+	"%.14g",
+
+	"[",
+	"]",
+	"(",
+	")",
+	"[",
+	"]",
+
+	print_string,
+	print_char,
+	array_elsize,
+	binop_prio,
+	unop_prio,
+	getstring,
+	getname,
+	get_number,
+	get_token,
+	print_op,
+	fix_bin_to_pref
+};
+
+struct langdep *pascal_dep = &pascal;
+
+static
+print_char(c)
+  int	c;
+{
+  c &= 0377;
+  fprintf(db_out, (c >= 040 && c < 0177) ? "'%c'" : "chr(%d)", c);
+}
+
+static
+print_string(f, s, len)
+  FILE	*f;
+  char	*s;
+  int	len;
+{
+  register char	*str = s;
+
+  putc('\'', f);
+  while (*str && len > 0) {
+	putc(*str, f);
+	if (*str++ == '\'') putc('\'', f);
+	len--;
+  }
+  putc('\'', f);
+}
+
+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;
+}
+
+static int
+unop_prio(op)
+  int	op;
+{
+  switch(op) {
+  case E_NOT:
+  	return 8;
+  case E_MIN:
+  case E_PLUS:
+	return 6;
+  }
+  return 1;
+}
+
+static int
+binop_prio(op)
+  int	op;
+{
+  switch(op) {
+  case E_SELECT:
+	return 9;
+  case E_ARRAY:
+	return 9;
+  case E_AND:
+  case E_MUL:
+  case E_DIV:
+  case E_MOD:
+	return 7;
+
+  case E_PLUS:
+  case E_MIN:
+  case E_OR:
+	return 6;
+
+  case E_IN:
+  case E_EQUAL:
+  case E_NOTEQUAL:
+  case E_LTEQUAL:
+  case E_GTEQUAL:
+  case E_LT:
+  case E_GT:
+	return 5;
+  }
+  return 1;
+}
+
+static int
+get_number(ch)
+  register int	ch;
+{
+  char buf[512+1];
+  register char *np = &buf[0];
+  int real_mode = 0;
+
+  while (is_dig(ch))	{
+	if (np < &buf[512]) *np++ = ch;
+	ch = getc(db_in);
+  }
+
+  if (ch == '.') {
+	real_mode = 1;
+  	if (np < &buf[512]) *np++ = '.';
+  	ch = getc(db_in);
+  	while (is_dig(ch)) {
+		/* 	Fractional part
+		*/
+		if (np < &buf[512]) *np++ = ch;
+		ch = getc(db_in);
+  	}
+  }
+
+  if (ch == 'E' || ch == 'e') {
+	/*	Scale factor
+	*/
+	real_mode = 1;
+	if (np < &buf[512]) *np++ = ch;
+	ch = getc(db_in);
+	if (ch == '+' || ch == '-') {
+		/*	Signed scalefactor
+		*/
+		if (np < &buf[512]) *np++ = ch;
+		ch = getc(db_in);
+	}
+	if (is_dig(ch)) {
+		do {
+			if (np < &buf[512]) *np++ = ch;
+			ch = getc(db_in);
+		} while (is_dig(ch));
+	}
+	else {
+		error("bad scale factor");
+	}
+  }
+
+  *np++ = '\0';
+  ungetc(ch, db_in);
+
+  if (np >= &buf[512]) {
+  	if (! real_mode) {
+		tok.ival = 0;
+		error("constant too long");
+  	}
+	else {
+		tok.fval = 0.0;
+		error("real constant too long");
+	}
+  }
+  else if (! real_mode) {
+	tok.ival = atol(buf);
+	return INTEGER;
+  }
+  tok.fval = atof(buf);
+  return REAL;
+}
+
+static int
+getname(c)
+  register int	c;
+{
+  char	buf[512+1];
+  register char	*p = &buf[0];
+  register struct idf *id;
+
+  do {
+	if (isupper(c)) c = tolower(c);
+	if (p - buf < 512) *p++ = c;
+	c = getc(db_in);
+  } while (in_idf(c));
+  ungetc(c, db_in);
+  *p = 0;
+  /* now recognize and, div, in, mod, not, or */
+  switch(buf[0]) {
+  case 'a':
+	if (strcmp(buf, "and") == 0) {
+		tok.ival = E_AND;
+		return BIN_OP;
+	}
+	break;
+  case 'd':
+	if (strcmp(buf, "div") == 0) {
+		tok.ival = E_DIV;
+		return BIN_OP;
+	}
+	break;
+  case 'i':
+	if (strcmp(buf, "in") == 0) {
+		tok.ival = E_IN;
+		return BIN_OP;
+	}
+	break;
+  case 'm':
+	if (strcmp(buf, "mod") == 0) {
+		tok.ival = E_MOD;
+		return BIN_OP;
+	}
+	break;
+  case 'n':
+	if (strcmp(buf, "not") == 0) {
+		tok.ival = E_NOT;
+		return PREF_OP;
+	}
+	break;
+  case 'o':
+	if (strcmp(buf, "or") == 0) {
+		tok.ival = E_OR;
+		return BIN_OP;
+	}
+	break;
+  }
+  id = str2idf(buf, 1);
+  tok.idf = id;
+  tok.str = id->id_text;
+  return id->id_reserved ? id->id_reserved : NAME;
+}
+
+static int
+get_token(c)
+  register int	c;
+{
+  switch(c) {
+  case '[':
+	tok.ival = E_ARRAY;
+	/* fall through */
+  case '(':
+  case ')':
+  case ']':
+  case '`':
+  case '{':
+  case '}':
+  case ':':
+  case ',':
+  case '\\':
+	return c;
+
+  case '.':
+	tok.ival = E_SELECT;
+	return SEL_OP;
+  case '+':
+	tok.ival = E_PLUS;
+	return PREF_OR_BIN_OP;
+  case '-':
+	tok.ival = E_MIN;
+	return PREF_OR_BIN_OP;
+  case '*':
+	tok.ival = E_MUL;
+	return BIN_OP;
+  case '/':
+	tok.ival = E_DIV;
+	return BIN_OP;
+  case '=':
+	tok.ival = E_EQUAL;
+	return BIN_OP;
+  case '<':
+	c = getc(db_in);
+	if (c == '>') {
+		tok.ival = E_NOTEQUAL;
+		return BIN_OP;
+	}
+	if (c == '=') {
+		tok.ival = E_LTEQUAL;
+		return BIN_OP;
+	}
+	ungetc(c, db_in);
+	tok.ival = E_LT;
+	return BIN_OP;
+  case '>':
+	c = getc(db_in);
+	if (c == '=') {
+		tok.ival = E_GTEQUAL;
+		return BIN_OP;
+	}
+	ungetc(c, db_in);
+	tok.ival = E_GT;
+	return BIN_OP;
+  case '^':
+	tok.ival = E_DEREF;
+	return POST_OP;
+  default:
+	error((c >= 040 && c < 0177) ? "%s'%c'" : "%s'\\0%o'", "illegal character ", c);
+	return LLlex();
+  }
+}
+
+static int 
+getstring(c)
+  int	c;
+{
+  register int ch;
+  char buf[512];
+  register int len = 0;
+
+  for (;;) {
+	ch = getc(db_in);
+	if (ch == c) {
+		ch = getc(db_in);
+		if (ch != c) {
+			ungetc(ch, db_in);
+			break;
+		}
+	}
+	if (ch == '\n') {
+		error("newline in string");
+		ungetc(ch, db_in);
+		break;
+	}
+	buf[len++] = ch;
+  }
+  buf[len++] = 0;
+  tok.str = Salloc(buf, (unsigned) len);
+  return STRING;
+}
+
+static
+print_op(f, p)
+  FILE		*f;
+  p_tree	p;
+{
+  switch(p->t_oper) {
+  case OP_UNOP:
+  	switch(p->t_whichoper) {
+	case E_MIN:
+		fputs("-", f);
+		print_node(f, p->t_args[0], 0);
+		break;
+	case E_PLUS:
+		fputs("+", f);
+		print_node(f, p->t_args[0], 0);
+		break;
+	case E_NOT:
+		fputs(" not ", f);
+		print_node(f, p->t_args[0], 0);
+		break;
+	case E_DEREF:
+		print_node(f, p->t_args[0], 0);
+		fputs("^", f);
+		break;
+	}
+	break;
+  case OP_BINOP:
+	if (p->t_whichoper == E_ARRAY) {
+		print_node(f, p->t_args[0], 0);
+		fputs("[", f);
+		print_node(f, p->t_args[1], 0);
+		fputs("]", f);
+		break;
+	}
+	if (p->t_whichoper == E_SELECT) {
+		print_node(f, p->t_args[0], 0);
+		fputs(".", f);
+		print_node(f, p->t_args[1], 0);
+		break;
+	}
+	fputs("(", f);
+	print_node(f, p->t_args[0], 0);
+	switch(p->t_whichoper) {
+	case E_AND:
+		fputs(" and ", f);
+		break;
+	case E_OR:
+		fputs(" or ", f);
+		break;
+	case E_DIV:
+		fputs("/", f);
+		break;
+	case E_MOD:
+		fputs(" mod ", f);
+		break;
+	case E_IN:
+		fputs(" in ", f);
+		break;
+	case E_PLUS:
+		fputs("+", f);
+		break;
+	case E_MIN:
+		fputs("-", f);
+		break;
+	case E_MUL:
+		fputs("*", f);
+		break;
+	case E_EQUAL:
+		fputs("=", f);
+		break;
+	case E_NOTEQUAL:
+		fputs("<>", f);
+		break;
+	case E_LTEQUAL:
+		fputs("<=", f);
+		break;
+	case E_GTEQUAL:
+		fputs(">=", f);
+		break;
+	case E_LT:
+		fputs("<", f);
+		break;
+	case E_GT:
+		fputs(">", f);
+		break;
+	}
+	print_node(f, p->t_args[1], 0);
+	fputs(")", f);
+	break;
+  }
+}
+
+static
+fix_bin_to_pref()
+{
+  /* No problems of this kind in Pascal */
+}

util/grind/print.c

@@ -139,13 +139,13 @@ print_params(tp, AB, static_link)
 	error("could not allocate enough memory");
 	return;
   }
-  if (static_link) p += pointer_size;
-  if (! get_bytes(size, AB, param_bytes)) {
-	free(param_bytes);
+  if (! get_bytes(size, AB, p)) {
+	free(p);
 	return;
   }
 
   while (i--) {
+	p = param_bytes + par->par_off;
 	if (par->par_kind == 'v' || par->par_kind == 'i') {
 		/* call by reference parameter, or
 		   call by value parameter, but address is passed;
@@ -173,7 +173,6 @@ print_params(tp, AB, static_link)
 	}
 	else print_val(par->par_type, par->par_type->ty_size, p, 1, 0, (char *)0);
 	if (i) fputs(", ", db_out);
-	p += param_size(par->par_type, par->par_kind);
 	par++;
   }
   free(param_bytes);

util/grind/run.c

@@ -203,10 +203,14 @@ start_child(p)
 	exit(1);
   }
 
-  /* debugger; don't close fild1[0] and fild2[1]; we want those file
-     descriptors occupied!
+  /* close fild1[0] and fild2[1]; but we want those file descriptors occupied,
+     so we re-occupy them.
   */
 
+  close(fild1[0]);
+  close(fild2[1]);
+  pipe(fild1);		/* to occupy file descriptors */
+
   signal(SIGPIPE, catch_sigpipe);
   {
 	struct message_hdr m;

util/grind/symbol.c

@@ -129,7 +129,7 @@ add_file(s)
   return sym;
 }
 
-p_scope
+static p_scope
 def_scope(s)
   p_symbol	s;
 {
@@ -169,7 +169,7 @@ consistent(p, sc)
 
   switch(p->t_oper) {
   case OP_NAME:
-#define CLASS	(FILELINK|FILESYM|PROC|FUNCTION|MODULE|TYPE|VAR|REGVAR|LOCVAR|VARPAR)
+#define CLASS	(FILELINK|FILESYM|PROC|FUNCTION|MODULE|TYPE|VAR|REGVAR|LOCVAR|VARPAR|LBOUND|UBOUND)
 	sym = Lookfromscope(p->t_idf, CLASS, sc->sc_static_encl);
 	if (sym) {
 		int precise = 1;
@@ -322,6 +322,8 @@ pr_sym(s)
   case REGVAR:
   case LOCVAR:
   case VARPAR:
+  case LBOUND:
+  case UBOUND:
 	fprintf(db_out, "Variable:\t");
 	break;
   case FIELD:

util/grind/symbol.hh

@@ -35,6 +35,8 @@ typedef struct symbol {
 #define FIELD		0x0400
 #define FILESYM		0x0800	/* a filename */
 #define FILELINK	0x1000	/* a filename without its suffix */
+#define LBOUND		0x2000	/* lower bound of array descriptor */
+#define UBOUND		0x4000	/* upper bound of array descriptor */
   struct idf	*sy_idf;	/* reference back to its idf structure */
   struct scope	*sy_scope;	/* scope in which this symbol resides */
   union {
@@ -42,6 +44,7 @@ typedef struct symbol {
 	t_name	syv_name;
 	struct file *syv_file;		/* for FILESYM */
 	struct symbol *syv_fllink;	/* for FILELINK */
+	struct symbol *syv_descr;	/* for LBOUND and UBOUND */
 	struct fields *syv_field;
   }	sy_v;
 #define sy_const	sy_v.syv_const
@@ -49,6 +52,7 @@ typedef struct symbol {
 #define sy_file		sy_v.syv_file
 #define sy_filelink	sy_v.syv_fllink
 #define sy_field	sy_v.syv_field
+#define sy_descr	sy_v.syv_descr
 } t_symbol, *p_symbol;
 
 /* ALLOCDEF "symbol" 50 */

util/grind/type.c

@@ -369,7 +369,8 @@ param_size(t, v)
 	/* addresss; only exception is a conformant array, which also
 	   takes a descriptor.
 	*/
-	if (t->ty_class == T_ARRAY &&
+	if (currlang == m2_dep &&
+	    t->ty_class == T_ARRAY &&
 	    t->ty_index->ty_class == T_SUBRANGE &&
 	    t->ty_index->ty_A) {
 		return pointer_size + 3 * int_size;
@@ -390,11 +391,16 @@ add_param_type(v, s)
   prc_type = sc->sc_definedby->sy_type;
   assert(prc_type->ty_class == T_PROCEDURE);
 
+  if (v == 'Z') {
+  	prc_type->ty_nbparams += 3 * int_size;
+	return;
+  }
   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_params[prc_type->ty_nparams - 1].par_off = s->sy_name.nm_value;
   prc_type->ty_nbparams += param_size(s->sy_type, v);
 }
 
@@ -418,6 +424,9 @@ compute_size(tp, AB)
   tp->ty_lb = low;
   if (tp->ty_index->ty_A & 2) {
 	high = get_int(AB+tp->ty_index->ty_up, int_size, T_INTEGER);
+  } else if (tp->ty_index->ty_A & 0200) {
+	high = get_int(AB+tp->ty_index->ty_up, int_size, T_INTEGER);
+	high += get_int(AB+tp->ty_index->ty_up+int_size, int_size, T_INTEGER);
   } else high = tp->ty_index->ty_up;
   tp->ty_hb = high;
   return (high - low + 1) * tp->ty_elements->ty_size;

util/grind/type.hh

@@ -19,6 +19,7 @@ struct literal {
 /* structure for parameters */
 struct param {
   struct type *par_type;	/* type of parameter */
+  long par_off;			/* offset of parameter */
   char par_kind;		/* kind of parameter ('p', 'i', or 'v') */
 };