newer version

lang/m2/comp/LLlex.c

@@ -248,8 +248,11 @@ again:
 		switch (ch) {
 		case 'H':
 Shex:			*np++ = '\0';
-			numtype = card_type;
 			tk->TOK_INT = str2long(&buf[1], 16);
+			if (tk->TOK_INT >= 0 && tk->TOK_INT <= max_int) {
+				numtype = intorcard_type;
+			}
+			else	numtype = card_type;
 			return tk->tk_symb = INTEGER;
 
 		case '8':
@@ -283,11 +286,17 @@ Shex:			*np++ = '\0';
 			PushBack(ch);
 			ch = *--np;
 			*np++ = '\0';
+			tk->TOK_INT = str2long(&buf[1], 8);
 			if (ch == 'C') {
 				numtype = char_type;
+				if (tk->TOK_INT < 0 || tk->TOK_INT > 255) {
+lexwarning("Character constant out of range");
+				}
+			}
+			else if (tk->TOK_INT >= 0 && tk->TOK_INT <= max_int) {
+				numtype = intorcard_type;
 			}
 			else	numtype = card_type;
-			tk->TOK_INT = str2long(&buf[1], 8);
 			return tk->tk_symb = INTEGER;
 
 		case 'A':

lang/m2/comp/Makefile

@@ -82,7 +82,7 @@ LLlex.o: LLlex.h Lpars.h class.h const.h f_info.h idf.h idfsize.h input.h inputt
 LLmessage.o: LLlex.h Lpars.h idf.h
 char.o: class.h
 error.o: LLlex.h debug.h errout.h f_info.h input.h inputtype.h main.h node.h
-main.o: LLlex.h Lpars.h debug.h def.h f_info.h idf.h input.h inputtype.h node.h scope.h standards.h tokenname.h type.h
+main.o: LLlex.h Lpars.h debug.h def.h f_info.h idf.h input.h inputtype.h ndirs.h node.h scope.h standards.h tokenname.h type.h
 symbol2str.o: Lpars.h
 tokenname.o: Lpars.h idf.h tokenname.h
 idf.o: idf.h
@@ -97,7 +97,7 @@ typequiv.o: def.h type.h
 node.o: LLlex.h debug.h def.h node.h type.h
 cstoper.o: LLlex.h Lpars.h idf.h node.h standards.h target_sizes.h type.h
 chk_expr.o: LLlex.h Lpars.h const.h debug.h def.h idf.h node.h scope.h standards.h type.h
-options.o: idfsize.h type.h
+options.o: idfsize.h main.h ndir.h type.h
 walk.o: LLlex.h Lpars.h debug.h def.h main.h node.h scope.h type.h
 tokenfile.o: Lpars.h
 program.o: LLlex.h Lpars.h debug.h def.h idf.h main.h node.h scope.h type.h

lang/m2/comp/Parameters

@@ -63,4 +63,8 @@ extern char options[];
 				   but what is a reasonable choice ???
 				*/
 
+!File: ndir.h
+#define NDIRS	16		/* maximum number of directories searched */
+
+
 

lang/m2/comp/chk_expr.c

@@ -35,7 +35,7 @@ chk_expr(expp)
 	switch(expp->nd_class) {
 	case Oper:
 		if (expp->nd_symb == '[') {
-			return chk_designator(expp, DESIGNATOR);
+			return chk_designator(expp, DESIGNATOR|VARIABLE);
 		}
 
 		return	chk_expr(expp->nd_left) &&
@@ -44,7 +44,7 @@ chk_expr(expp)
 
 	case Uoper:
 		if (expp->nd_symb == '^') {
-			return chk_designator(expp, DESIGNATOR);
+			return chk_designator(expp, DESIGNATOR|VARIABLE);
 		}
 
 		return	chk_expr(expp->nd_right) &&
@@ -66,13 +66,13 @@ chk_expr(expp)
 		return chk_set(expp);
 
 	case Name:
-		return chk_designator(expp, DESIGNATOR);
+		return chk_designator(expp, VALUE);
 
 	case Call:
 		return chk_call(expp);
 
 	case Link:
-		return chk_designator(expp, DESIGNATOR);
+		return chk_designator(expp, DESIGNATOR|VALUE);
 
 	default:
 		assert(0);
@@ -99,7 +99,7 @@ chk_set(expp)
 	if (nd = expp->nd_left) {
 		/* A type was given. Check it out
 		*/
-		if (! chk_designator(nd, QUALONLY)) return 0;
+		if (! chk_designator(nd, 0)) return 0;
 
 		assert(nd->nd_class == Def);
 		df = nd->nd_def;
@@ -270,12 +270,15 @@ getname(argp, kinds)
 		return 0;
 	}
 	argp = argp->nd_right;
-	if (! chk_designator(argp->nd_left, QUALONLY)) return 0;
+	if (! chk_designator(argp->nd_left, 0)) return 0;
+
 	assert(argp->nd_left->nd_class == Def);
+
 	if (!(argp->nd_left->nd_def->df_kind & kinds)) {
 		node_error(argp, "unexpected type");
 		return 0;
 	}
+
 	return argp;
 }
 
@@ -294,9 +297,8 @@ chk_call(expp)
 	*/
 	expp->nd_type = error_type;
 	left = expp->nd_left;
-	if (! chk_designator(left, DESIGNATOR)) return 0;
+	if (! chk_designator(left, 0)) return 0;
 
-	if (left->nd_type == error_type) return 0;
 	if (left->nd_class == Def &&
 	    (left->nd_def->df_kind & (D_HTYPE|D_TYPE|D_HIDDEN))) {
 		/* It was a type cast. This is of course not portable.
@@ -310,7 +312,7 @@ node_error(expp, "only one parameter expected in type cast");
 		arg = arg->nd_left;
 		if (! chk_expr(arg)) return 0;
 		if (arg->nd_type->tp_size != left->nd_type->tp_size) {
-node_error(expp, "size of type in type cast does not match size of operand");
+node_error(expp, "unequal sizes in type cast");
 		}
 		arg->nd_type = left->nd_type;
 		FreeNode(expp->nd_left);
@@ -352,30 +354,59 @@ chk_proccall(expp)
 	register struct node *arg;
 	register struct paramlist *param;
 
-	expp->nd_type = left->nd_type->next;
-	param = left->nd_type->prc_params;
 	arg = expp;
+	arg->nd_type = left->nd_type->next;
+	param = left->nd_type->prc_params;
 
 	while (param) {
-		arg = getarg(arg, 0);
+		if (!(arg = getarg(arg, 0))) return 0;
-		if (!arg) return 0;
+
-		if (param->par_var &&
+		if (! TstParCompat(param->par_type,
-		    ! TstCompat(param->par_type, arg->nd_left->nd_type)) {
+				   arg->nd_left->nd_type,
-node_error(arg->nd_left, "type incompatibility in var parameter");
+				   param->par_var)) {
-			return 0;
+node_error(arg->nd_left, "type incompatibility in parameter");
-		}
-		else
-		if (!param->par_var &&
-		    !TstAssCompat(param->par_type, arg->nd_left->nd_type)) {
-node_error(arg->nd_left, "type incompatibility in value parameter");
 			return 0;
 		}
+
 		param = param->next;
 	}
+
 	if (arg->nd_right) {
 		node_error(arg->nd_right, "too many parameters supplied");
 		return 0;
 	}
+
+	return 1;
+}
+
+static int
+FlagCheck(expp, df, flag)
+	struct node *expp;
+	struct def *df;
+{
+	/*	See the routine "chk_designator" for an explanation of
+		"flag". Here, a definition "df" is checked against it.
+	*/
+
+	if ((flag & VARIABLE) &&
+	    !(df->df_kind & (D_FIELD|D_VARIABLE))) {
+		node_error(expp, "variable expected");
+		return 0;
+	}
+
+	if ((flag & HASSELECTORS) &&
+	    ( !(df->df_kind & (D_VARIABLE|D_FIELD|D_MODULE)) ||
+	      df->df_type->tp_fund != T_RECORD)) {
+		node_error(expp, "illegal selection");
+		return 0;
+	}
+
+	if ((flag & VALUE) &&
+	    ( !(df->df_kind & (D_VARIABLE|D_FIELD|D_CONST|D_ENUM)))) {
+		node_error(expp, "value expected");
+		return 0;
+	}
+
 	return 1;
 }
 
@@ -384,7 +415,15 @@ chk_designator(expp, flag)
 	register struct node *expp;
 {
 	/*	Find the name indicated by "expp", starting from the current
-		scope.
+		scope.  "flag" indicates the kind of designator we expect:
+		It contains the flags VARIABLE, indicating that the result must
+		be something that can be assigned to.
+		It may also contain the flag VALUE, indicating that a
+		value is expected. In this case, VARIABLE may not be set.
+		It also contains the flag DESIGNATOR, indicating that '['
+		and '^' are allowed for this designator.
+		Also contained may be the flag HASSELECTORS, indicating that
+		the result must have selectors.
 	*/
 	register struct def *df;
 	register struct type *tp;
@@ -403,21 +442,20 @@ chk_designator(expp, flag)
 		assert(expp->nd_symb == '.');
 		assert(expp->nd_right->nd_class == Name);
 
-		if (! chk_designator(expp->nd_left, flag)) return 0;
+		if (! chk_designator(expp->nd_left,
+				     (flag|HASSELECTORS)&DESIGNATOR)) return 0;
+
 		tp = expp->nd_left->nd_type;
-		if (tp == error_type) return 0;
+
-		else if (tp->tp_fund != T_RECORD) {
+		assert(tp->tp_fund == T_RECORD);
-			/* This is also true for modules */
+
-			node_error(expp,"illegal selection");
+		df = lookup(expp->nd_right->nd_IDF, tp->rec_scope);
-			return 0;
-		}
-		else df = lookup(expp->nd_right->nd_IDF, tp->rec_scope);
 
 		if (!df) {
 			id_not_declared(expp->nd_right);
 			return 0;
 		}
-		else if (df != ill_df) {
+		else {
 			expp->nd_type = df->df_type;
 			if (!(df->df_flags & (D_EXPORTED|D_QEXPORTED))) {
 node_error(expp->nd_right,
@@ -434,12 +472,16 @@ df->df_idf->id_text);
 			FreeNode(expp->nd_right);
 			expp->nd_left = expp->nd_right = 0;
 		}
-		else	return 1;
+		else {
+			return FlagCheck(expp->nd_right, df, flag);
+		}
 	}
 
 	if (expp->nd_class == Def) {
 		df = expp->nd_def;
 
+		if (! FlagCheck(expp, df, flag)) return 0;
+
 		if (df->df_kind & (D_ENUM | D_CONST)) {
 			if (df->df_kind == D_ENUM) {
 				expp->nd_class = Value;
@@ -455,7 +497,7 @@ df->df_idf->id_text);
 		return 1;
 	}
 
-	if (flag == QUALONLY) {
+	if (! (flag & DESIGNATOR)) {
 		node_error(expp, "identifier expected");
 		return 0;
 	}
@@ -466,7 +508,7 @@ df->df_idf->id_text);
 		assert(expp->nd_symb == '[');
 
 		if ( 
-		    	!chk_designator(expp->nd_left, DESIGNATOR)
+		    	!chk_designator(expp->nd_left, DESIGNATOR|VARIABLE)
 		   ||
 		    	!chk_expr(expp->nd_right)
 		   ||
@@ -498,7 +540,10 @@ df->df_idf->id_text);
 	if (expp->nd_class == Uoper) {
 		assert(expp->nd_symb == '^');
 
-		if (! chk_designator(expp->nd_right, DESIGNATOR)) return 0;
+		if (! chk_designator(expp->nd_right, DESIGNATOR|VARIABLE)) {
+			return 0;
+		}
+
 		if (expp->nd_right->nd_type->tp_fund != T_POINTER) {
 node_error(expp, "illegal operand for unary operator \"%s\"",
 symbol2str(expp->nd_symb));

lang/m2/comp/declar.g

@@ -17,6 +17,8 @@ static char *RcsId = "$Header$";
 #include	"misc.h"
 #include	"main.h"
 
+#include	"debug.h"
+
 int		proclevel = 0;	/* nesting level of procedures */
 extern char	*sprint();
 extern struct def *currentdef;
@@ -68,6 +70,10 @@ error("inconsistent procedure declaration for \"%s\"", df->df_idf->id_text);
 		  }
 		  df->df_type = tp;
 		  *pdf = df;
+
+		  DO_DEBUG(1, type == D_PROCEDURE && 
+				(print("proc %s:", df->df_idf->id_text),
+				 DumpType(tp), print("\n")));
 		}
 ;
 
@@ -107,9 +113,8 @@ FormalParameters(int doparams;
 	'('
 	[
 		FPSection(doparams, pr, parmaddr)	
-			{ pr1 = *pr; }
 		[
-			{ for (; pr1->next; pr1 = pr1->next) ; }
+			{ for (pr1 = *pr; pr1->next; pr1 = pr1->next) ; }
 			';' FPSection(doparams, &(pr1->next), parmaddr)
 		]*
 	]?
@@ -366,7 +371,7 @@ FieldList(struct scope *scope; arith *cnt; int *palign;)
 				{ warning("Old fashioned Modula-2 syntax!");
 				  id = gen_anon_idf();
 				  df = ill_df;
-				  if (chk_designator(nd, QUALONLY) &&
+				  if (chk_designator(nd, 0) &&
 				      (nd->nd_class != Def ||
 				       !(nd->nd_def->df_kind &
 					 (D_ERROR|D_TYPE|D_HTYPE|D_HIDDEN)))) {

lang/m2/comp/defmodule.c

@@ -26,7 +26,6 @@ GetFile(name)
 	/*	Try to find a file with basename "name" and extension ".def",
 		in the directories mentioned in "DEFPATH".
 	*/
-	extern char *DEFPATH[];
 	char buf[256];
 	char *strcpy(), *strcat();
 

lang/m2/comp/expression.g

@@ -43,7 +43,7 @@ qualident(int types; struct def **pdf; char *str; struct node **p;)
 			{ if (types) {
 				df = ill_df;
 
-				if (chk_designator(nd, QUALONLY)) {
+				if (chk_designator(nd, 0)) {
 				    if (nd->nd_class != Def) {
 					node_error(nd, "%s expected", str);
 				    }
@@ -83,7 +83,7 @@ ExpList(struct node **pnd;)
 		','		{ *nd = MkNode(Link, NULLNODE, NULLNODE, &dot);
 				}
 		expression(&(*nd)->nd_left)
-				{ nd = &((*pnd)->nd_right); }
+				{ nd = &((*nd)->nd_right); }
 	]*
 ;
 

lang/m2/comp/main.c

@@ -19,14 +19,14 @@ static char *RcsId = "$Header$";
 #include	"node.h"
 
 #include	"debug.h"
+#include	"ndir.h"
 
 char	options[128];
 int	DefinitionModule; 
 int	SYSTEMModule = 0;
 char	*ProgName;
 extern int err_occurred;
-char	*DEFPATH[128];
+char	*DEFPATH[NDIRS+1];
-char	*getenv();
 struct def *Defined;
 
 main(argc, argv)
@@ -67,7 +67,8 @@ Compile(src, dst)
 	}
 	LineNumber = 1;
 	FileName = src;
-	init_DEFPATH();
+	DEFPATH[0] = "";
+	DEFPATH[NDIRS] = 0;
 	init_idf();
 	init_cst();
 	reserve(tkidf);
@@ -181,23 +182,6 @@ add_standards()
 	df->enm_next = 0;
 }
 
-init_DEFPATH()
-{
-	register char *p = getenv("M2path");
-	register int i = 0;
-
-	if (p) {
-		while (*p) {
-			DEFPATH[i++] = p;
-			while (*p && *p != ':') p++;
-			if (*p) *p++ = '\0';
-		}
-	}
-	else DEFPATH[i++] = "";
-
-	DEFPATH[i] = 0;
-}
-
 do_SYSTEM()
 {
 	/*	Simulate the reading of the SYSTEM definition module

lang/m2/comp/main.h

@@ -2,17 +2,18 @@
 
 /* $Header$ */
 
-extern char options[];	/* Indicating which options were given */
+extern char options[];	/* indicating which options were given */
 
 extern int DefinitionModule;
-			/* Flag indicating that we are reading a definition
+			/* flag indicating that we are reading a definition
 			   module
 			*/
 
-extern int SYSTEMModule;/* Flag indicating that we are handling the SYSTEM
+extern int SYSTEMModule;/* flag indicating that we are handling the SYSTEM
 			   module
 			*/
 extern struct def *Defined;
-			/* Definition structure of module defined in this
+			/* definition structure of module defined in this
 			   compilation
 			*/
+extern char *DEFPATH[];	/* search path for DEFINITION MODULE's */

lang/m2/comp/node.H

@@ -36,5 +36,8 @@ struct node {
 extern struct node *MkNode();
 
 #define NULLNODE ((struct node *) 0)
-#define QUALONLY 0
+
 #define DESIGNATOR 1
+#define HASSELECTORS 2
+#define VARIABLE 4
+#define VALUE 8

lang/m2/comp/options.c

@@ -6,12 +6,15 @@ static char *RcsId = "$Header$";
 #include	<em_label.h>
 
 #include	"idfsize.h"
+#include	"ndir.h"
 
 #include	"type.h"
+#include	"main.h"
 
-extern char options[];
 extern int	idfsize;
 
+static int	ndirs;
+
 do_option(text)
 	char *text;
 {
@@ -37,6 +40,13 @@ do_option(text)
 		options['p'] = 1;
 		break;
 
+	case 'I' :
+		if (++ndirs >= NDIRS) {
+			fatal("Too many -I options");
+		}
+		DEFPATH[ndirs] = text;
+		break;
+
 	case 'V' :	/* set object sizes and alignment requirements	*/
 	{
 		arith size;

lang/m2/comp/type.c

@@ -436,3 +436,70 @@ lcm(m, n)
  	*/
 	return m * (n / gcd(m, n));
 }
+
+#ifdef DEBUG
+DumpType(tp)
+	register struct type *tp;
+{
+	print(" a:%d; s:%ld;", tp->tp_align, (long) tp->tp_size);
+	if (tp->next && tp->tp_fund != T_POINTER) {
+		/* Avoid printing recursive types!
+		*/
+		print(" n:(");
+		DumpType(tp->next);
+		print(")");
+	}
+
+	print(" f:");
+	switch(tp->tp_fund) {
+	case T_RECORD:
+		print("RECORD"); break;
+	case T_ENUMERATION:
+		print("ENUMERATION; n:%d", tp->enm_ncst); break;
+	case T_INTEGER:
+		print("INTEGER"); break;
+	case T_CARDINAL:
+		print("CARDINAL"); break;
+	case T_REAL:
+		print("REAL"); break;
+	case T_POINTER:
+		print("POINTER"); break;
+	case T_CHAR:
+		print("CHAR"); break;
+	case T_WORD:
+		print("WORD"); break;
+	case T_SET:
+		print("SET"); break;
+	case T_SUBRANGE:
+		print("SUBRANGE %ld-%ld", (long) tp->sub_lb, (long) tp->sub_ub);
+		break;
+	case T_PROCEDURE:
+		{
+		register struct paramlist *par = tp->prc_params;
+
+		print("PROCEDURE");
+		if (par) {
+			print("; p:");
+			while(par) {
+				if (par->par_var) print("VAR ");
+				DumpType(par->par_type);
+				par = par->next;
+			}
+		}
+		break;
+		}
+	case T_ARRAY:
+		print("ARRAY %ld-%ld", (long) tp->arr_lb, (long) tp->arr_ub);
+		print("; el:");
+		DumpType(tp->arr_elem);
+		break;
+	case T_STRING:
+		print("STRING"); break;
+	case T_INTORCARD:
+		print("INTORCARD"); break;
+	default:
+		assert(0);
+	}
+	print(";");
+}
+#endif

lang/m2/comp/typequiv.c

@@ -150,3 +150,21 @@ int TstAssCompat(tp1, tp2)
 
 	return 0;
 }
+
+int TstParCompat(formaltype, actualtype, VARflag)
+	struct type *formaltype, *actualtype;
+{
+	/*	Check type compatibility for a parameter in a procedure
+		call
+	*/
+
+	return
+		TstCompat(formaltype, actualtype)
+	    ||
+		( !VARflag && TstAssCompat(formaltype, actualtype))
+	    ||
+		(  formaltype->tp_fund == T_ARRAY
+		&& formaltype->next == 0	
+		&& actualtype->tp_fund == T_ARRAY
+		&& TstTypeEquiv(formaltype->arr_elem, actualtype->arr_elem));
+}

lang/m2/comp/walk.c

@@ -181,7 +181,9 @@ WalkStat(nd, lab)
 	register struct node *right = nd->nd_right;
 
 	if (nd->nd_class == Call) {
+		if (chk_call(nd)) {
 			/* ??? */
+		}
 		return;
 	}
 
@@ -189,6 +191,8 @@ WalkStat(nd, lab)
 
 	switch(nd->nd_symb) {
 	case BECOMES:
+		WalkExpr(nd->nd_right);
+		WalkDesignator(nd->nd_left);
 		/* ??? */
 		break;
 
@@ -309,6 +313,19 @@ WalkExpr(nd)
 	}
 }
 
+WalkDesignator(nd)
+	struct node *nd;
+{
+	/*	Check designator and generate code for it
+	*/
+
+	DO_DEBUG(1, (DumpTree(nd), print("\n")));
+
+	if (chk_designator(nd, DESIGNATOR|VARIABLE)) {
+		/* ??? */
+	}
+}
+
 #ifdef DEBUG
 DumpTree(nd)
 	struct node *nd;