Added Pascal support

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 */
+}