newer version

lang/m2/comp/chk_expr.c

@@ -50,6 +50,8 @@ chk_expr(expp, const)
 		return chk_call(expp, const);
 	case Link:
 		return chk_name(expp, const);
+	default:
+		assert(0);
 	}
 	/*NOTREACHED*/
 }
@@ -58,7 +60,85 @@ int
 chk_set(expp, const)
 	register struct node *expp;
 {
-	/* ??? */
+	struct type *tp;
+	struct def *df;
+	register struct node *nd;
+	extern struct def *findname();
+
+	assert(expp->nd_symb == SET);
+
+	/* First determine the type of the set
+	*/
+	if (expp->nd_left) {
+		/* A type was given. Check it out
+		*/
+		df = findname(expp->nd_left);
+		if ((df->df_kind != D_TYPE && df->df_kind != D_ERROR) ||
+		    (df->df_type->tp_fund != SET)) {
+			node_error(expp, "Illegal set type");
+			return 0;
+		}
+		tp = df->df_type;
+	}
+	else	tp = bitset_type;
+
+	/* Now check the elements given
+	*/
+	nd = expp->nd_right;
+	while (nd) {
+		assert(nd->nd_class == Link && nd->nd_symb == ',');
+		if (!chk_el(nd->nd_left, const, tp->next, 0)) return 0;
+		nd = nd->nd_right;
+	}
+	return 1;
+}
+
+int
+chk_el(expp, const, tp, level)
+	struct node *expp;
+	struct type *tp;
+{
+	/*	Check elements of a set. This routine may call itself
+		recursively, but only once.
+	*/
+	if (expp->nd_class == Link && expp->nd_symb == UPTO) {
+		/*  { ... , expr1 .. expr2,  ... } */
+		if (level) {
+			node_error(expp, "Illegal set element");
+			return 0;
+		}
+		if (!chk_el(expp->nd_left, const, tp, 1) ||
+		    !chk_el(expp->nd_right, const, tp, 1)) {
+			return 0;
+		}
+		if (expp->nd_left->nd_class == Value &&
+		    expp->nd_right->nd_class == Value) {
+		    	if (expp->nd_left->nd_INT > expp->nd_right->nd_INT) {
+node_error(expp, "Lower bound exceeds upper bound in range");
+				return 0;
+			}
+		}
+		return 1;
+	}
+	if (!chk_expr(expp, const)) return 0;
+	if (!TstCompat(tp, expp->nd_type)) {
+		node_error(expp, "Set element has incompatible type");
+		return 0;
+	}
+	if (expp->nd_class == Value) {
+	    	if ((tp->tp_fund != ENUMERATION &&
+		     (expp->nd_INT < tp->sub_lb || expp->nd_INT > tp->sub_ub))
+		   ||
+		    (tp->tp_fund == ENUMERATION &&
+		     (expp->nd_INT < 0 || expp->nd_INT > tp->enm_ncst))
+		   ) {
+			node_error(expp, "Set element out of range");
+#ifdef DEBUG
+			debug("%d (%d, %d)", (int) expp->nd_INT, (int) tp->sub_lb, (int) tp->sub_ub);
+#endif
+			return 0;
+		}
+	}
 	return 1;
 }
 

lang/m2/comp/const.h

@@ -8,5 +8,4 @@ extern int
 	mach_long_size;	/* size of long on this machine == sizeof(long) */
 extern arith
 	max_int,	/* maximum integer on target machine	*/
-	max_unsigned,	/* maximum unsigned on target machine	*/
-	max_longint;	/* maximum longint on target machine	*/
+	max_unsigned;	/* maximum unsigned on target machine	*/

lang/m2/comp/cstoper.c

@@ -267,10 +267,10 @@ init_cst()
 	}
 	mach_long_size = i;
 	mach_long_sign = 1 << (mach_long_size * 8 - 1);
-	if (sizeof(long) < mach_long_size)
+	if (int_size > mach_long_size) {
 		fatal("sizeof (long) insufficient on this machine");
+	}
 
 	max_int = full_mask[int_size] & ~(1 << (int_size * 8 - 1));
-	max_longint = full_mask[lint_size] & ~(1 << (lint_size * 8 - 1));
 	max_unsigned = full_mask[int_size];
 }

lang/m2/comp/declar.g

@@ -233,8 +233,8 @@ IdentList(struct node **p;)
 
 SubrangeType(struct type **ptp;)
 {
-	struct type *tp;
-	struct node *nd1 = 0, *nd2 = 0;
+	struct node *nd1, *nd2;
+	extern struct type *subr_type();
 }:
 	/*
 	   This is not exactly the rule in the new report, but see
@@ -243,17 +243,7 @@ SubrangeType(struct type **ptp;)
 	'[' ConstExpression(&nd1)
 	UPTO ConstExpression(&nd2)
 	']'
-	/*
-	   Evaluate the expressions. Check that they are indeed constant.
-	   ???
-	   Leave the basetype of the subrange in tp;
-	*/
-			{
-			  /* For the time being: */
-			  tp = int_type;
-			  tp = construct_type(SUBRANGE, tp);
-			  *ptp = tp;
-			}
+			{ *ptp = subr_type(nd1, nd2); }
 ;
 
 ArrayType(struct type **ptp;)
@@ -350,10 +340,11 @@ CaseLabels
 SetType(struct type **ptp;)
 {
 	struct type *tp;
+	struct type *set_type();
 } :
 	SET OF SimpleType(&tp)
 			{ 
-			  *ptp = construct_type(SET, tp);
+			  *ptp = set_type(tp);
 			}
 ;
 

lang/m2/comp/defmodule.c

@@ -25,6 +25,7 @@ GetFile(name)
 	*/
 	extern char *DEFPATH[];
 	char buf[256];
+	char *strcpy(), *strcat();
 
 	(void) strcpy(buf, name);
 	if (strlen(buf) > 10) {

lang/m2/comp/expression.g

@@ -91,6 +91,7 @@ ConstExpression(struct node **pnd;):
 		     ( debug("Constant expression:"),
 		       PrNode(*pnd)));
 		  (void) chk_expr(*pnd, 1);
+		  DO_DEBUG(3, PrNode(*pnd));
 		}
 ;
 

lang/m2/comp/type.c

@@ -13,6 +13,8 @@ static char *RcsId = "$Header$";
 #include	"idf.h"
 #include	"LLlex.h"
 #include	"node.h"
+#include	"const.h"
+#include	"debug.h"
 
 /*	To be created dynamically in main() from defaults or from command
 	line parameters.
@@ -129,6 +131,7 @@ init_types()
 	register struct type *tp;
 
 	char_type = standard_type(CHAR, 1, (arith) 1);
+	char_type->enm_ncst = 256;
 	bool_type = standard_type(BOOLEAN, 1, (arith) 1);
 	int_type = standard_type(INTEGER, int_align, int_size);
 	longint_type = standard_type(LONGINT, lint_align, lint_size);
@@ -217,8 +220,87 @@ chk_basesubrange(tp, base)
 	else if (base != card_type && base != int_type) {
 		error("Illegal base for a subrange");
 	}
+	else if (base == int_type && tp->next == card_type &&
+		 (tp->sub_ub > max_int || tp->sub_ub)) {
+		error("Upperbound to large for type INTEGER");
+	}
 	else if (base != tp->next && base != int_type) {
 		error("Specified base does not conform");
 	}
 	tp->next = base;
 }
+
+struct type *
+subr_type(lb, ub)
+	struct node *lb, *ub;
+{
+	/*	Construct a subrange type from the constant expressions
+		indicated by "lb" and "ub", but first perform some
+		checks
+	*/
+	register struct type *tp = lb->nd_type;
+
+	if (!TstCompat(lb->nd_type, ub->nd_type)) {
+		node_error(ub, "Types of subrange bounds not compatible");
+		return error_type;
+	}
+
+	if (tp->tp_fund == SUBRANGE) tp = tp->next;
+	if (tp == intorcard_type) tp = card_type;	/* lower bound > 0 */
+
+	/* Check base type
+	*/
+	if (tp != int_type && tp != card_type && tp != char_type &&
+	    tp->tp_fund != ENUMERATION) {
+		/* BOOLEAN is also an ENUMERATION type
+		*/
+		node_error(ub, "Illegal base type for subrange");
+		return error_type;
+	}
+
+	/* Check bounds
+	*/
+	if (lb->nd_INT > ub->nd_INT) {
+		node_error(ub, "Lower bound exceeds upper bound");
+	}
+
+	/* Now construct resulting type
+	*/
+	tp = construct_type(SUBRANGE, tp);
+	tp->sub_lb = lb->nd_INT;
+	tp->sub_ub = ub->nd_INT;
+	DO_DEBUG(2,debug("Creating subrange type %ld-%ld", (long)lb->nd_INT,(long)ub->nd_INT));
+	return tp;
+}
+#define MAX_SET	1024	/* ??? Maximum number of elements in a set */
+
+struct type *
+set_type(tp)
+	struct type *tp;
+{
+	/*	Construct a set type with base type "tp", but first
+		perform some checks
+	*/
+	int lb, ub;
+
+	if (tp->tp_fund == SUBRANGE) {
+		if ((lb = tp->sub_lb) < 0 || (ub = tp->sub_ub) > MAX_SET - 1) {
+			error("Set type limits exceeded");
+			return error_type;
+		}
+	}
+	else if (tp->tp_fund == ENUMERATION || tp == char_type) {
+		lb = 0;
+		if ((ub = tp->enm_ncst - 1) > MAX_SET - 1) {
+			error("Set type limits exceeded");
+			return error_type;
+		}
+	}
+	else {
+		error("illegal base type for set");
+		return error_type;
+	}
+	tp = construct_type(SET, tp);
+	tp->tp_size = align(((ub - lb) + 7)/8, wrd_align);
+	return tp;
+}

lang/m2/comp/typequiv.c

@@ -19,6 +19,10 @@ TstTypeEquiv(tp1, tp2)
 	*/
 
 	return     tp1 == tp2
+		||
+		   tp1 == error_type
+		||
+		   tp2 == error_type
 		||
 		   ( 
 		     tp1 && tp1->tp_fund == PROCEDURE
@@ -61,9 +65,19 @@ TstCompat(tp1, tp2)
 		Modula-2 Report for a definition of "compatible".
 	*/
 	if (TstTypeEquiv(tp1, tp2)) return 1;
-	if (tp2->tp_fund == SUBRANGE) tp1 = tp1->next;
-	if (tp2->tp_fund == SUBRANGE) tp1 = tp1->next;
+	if (tp1->tp_fund == SUBRANGE) tp1 = tp1->next;
+	if (tp2->tp_fund == SUBRANGE) tp2 = tp2->next;
 	return	tp1 == tp2
+	    ||
+		(  tp1 == intorcard_type
+		&&
+		   (tp2 == int_type || tp2 == card_type)
+		)
+	    ||
+		(  tp2 == intorcard_type
+		&&
+		   (tp1 == int_type || tp1 == card_type)
+		)
 	    ||
 		(  tp1 == address_type
 		&&