newer version

lang/m2/comp/LLlex.c

@@ -76,7 +76,7 @@ GetString(upto)
 	register struct string *str = &string;
 	register char *p;
 	
-	str->s_str = p = Malloc((unsigned) (str->s_length = ISTRSIZE));
+	str->s_str = p = Malloc(str->s_length = ISTRSIZE);
 	LoadChar(ch);
 	while (ch != upto)	{
 		if (class(ch) == STNL)	{

lang/m2/comp/Makefile

@@ -38,7 +38,7 @@ hfiles:	Parameters make.hfiles
 	touch hfiles
 
 main:	$(OBJ) Makefile
-	$(CC) $(LFLAGS) $(OBJ) $(LIBDIR)/libcomp.a $(LIBDIR)/malloc.o /user1/erikb/em/lib/libprint.a /user1/erikb/em/lib/libstr.a /user1/erikb/em/lib/libsystem.a -o main
+	$(CC) $(LFLAGS) $(OBJ) /user1/erikb/em/lib/libem_mes.a /user1/erikb/em/lib/libeme.a $(LIBDIR)/libcomp.a $(LIBDIR)/malloc.o /user1/erikb/em/lib/libprint.a /user1/erikb/em/lib/libstr.a /user1/erikb/em/lib/libsystem.a -o main
 	size main
 
 clean:
@@ -91,12 +91,13 @@ type.o: LLlex.h const.h debug.h def.h idf.h node.h target_sizes.h type.h
 def.o: LLlex.h debug.h def.h idf.h main.h node.h scope.h type.h
 scope.o: LLlex.h debug.h def.h idf.h node.h scope.h type.h
 misc.o: LLlex.h f_info.h idf.h misc.h node.h
-enter.o: LLlex.h def.h idf.h node.h scope.h type.h
+enter.o: LLlex.h def.h idf.h main.h node.h scope.h type.h
 defmodule.o: LLlex.h debug.h def.h f_info.h idf.h input.h inputtype.h scope.h
 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
 tokenfile.o: Lpars.h
 program.o: LLlex.h Lpars.h debug.h def.h idf.h main.h node.h scope.h type.h
 declar.o: LLlex.h Lpars.h def.h idf.h misc.h node.h scope.h type.h

lang/m2/comp/char.tab

@@ -23,7 +23,7 @@ STEOI:\200
 %	INIDF
 %
 %C
-1:a-zA-Z_0-9
+1:a-zA-Z0-9
 %Tchar inidf[] = {
 %F	%s,
 %p

lang/m2/comp/chk_expr.c

@@ -8,6 +8,7 @@ static char *RcsId = "$Header$";
 #include	<em_label.h>
 #include	<assert.h>
 #include	<alloc.h>
+
 #include	"Lpars.h"
 #include	"idf.h"
 #include	"type.h"
@@ -17,6 +18,7 @@ static char *RcsId = "$Header$";
 #include	"scope.h"
 #include	"const.h"
 #include	"standards.h"
+
 #include	"debug.h"
 
 int
@@ -25,7 +27,7 @@ chk_expr(expp)
 {
 	/*	Check the expression indicated by expp for semantic errors,
 		identify identifiers used in it, replace constants by
-		their value.
+		their value, and try to evaluate the expression.
 	*/
 
 	switch(expp->nd_class) {
@@ -33,25 +35,32 @@ chk_expr(expp)
 		return	chk_expr(expp->nd_left) &&
 			chk_expr(expp->nd_right) &&
 			chk_oper(expp);
+
 	case Uoper:
 		return	chk_expr(expp->nd_right) &&
 			chk_uoper(expp);
+
 	case Value:
 		switch(expp->nd_symb) {
 		case REAL:
 		case STRING:
 		case INTEGER:
 			return 1;
+
 		default:
 			assert(0);
 		}
 		break;
+
 	case Xset:
 		return chk_set(expp);
+
 	case Name:
 		return chk_name(expp);
+
 	case Call:
 		return chk_call(expp);
+
 	case Link:
 		return chk_name(expp);
 	default:
@@ -82,9 +91,9 @@ chk_set(expp)
 		findname(expp->nd_left);
 		assert(expp->nd_left->nd_class == Def);
 		df = expp->nd_left->nd_def;
-		if ((df->df_kind != D_TYPE && df->df_kind != D_ERROR) ||
+		if (!(df->df_kind & (D_TYPE|D_ERROR)) ||
 		    (df->df_type->tp_fund != T_SET)) {
-			node_error(expp, "Illegal set type");
+			node_error(expp, "illegal set type");
 			return 0;
 		}
 		tp = df->df_type;
@@ -93,7 +102,8 @@ chk_set(expp)
 
 	/* Now check the elements given, and try to compute a constant set.
 	*/
-	set = (arith *) Malloc(tp->tp_size * sizeof(arith) / word_size);
+	set = (arith *)
+		Malloc((unsigned) (tp->tp_size * sizeof(arith) / word_size));
 	nd = expp->nd_right;
 	while (nd) {
 		assert(nd->nd_class == Link && nd->nd_symb == ',');
@@ -102,7 +112,10 @@ chk_set(expp)
 	}
 	expp->nd_type = tp;
 	if (set) {
-		/* Yes, in was a constant set, and we managed to compute it!
+		/* Yes, it was a constant set, and we managed to compute it!
+		   Notice that at the moment there is no such thing as
+		   partial evaluation. Either we evaluate the set, or we
+		   don't (at all). Improvement not neccesary. (???)
 		*/
 		expp->nd_class = Set;
 		expp->nd_set = set;
@@ -123,6 +136,8 @@ chk_el(expp, tp, set)
 		recursively.
 		Also try to compute the set!
 	*/
+	register int i;
+
 	if (expp->nd_class == Link && expp->nd_symb == UPTO) {
 		/* { ... , expr1 .. expr2,  ... }
 		   First check expr1 and expr2, and try to compute them.
@@ -136,10 +151,9 @@ chk_el(expp, tp, set)
 			/* We have a constant range. Put all elements in the
 			   set
 			*/
-			register int i;
 
 		    	if (expp->nd_left->nd_INT > expp->nd_right->nd_INT) {
-node_error(expp, "Lower bound exceeds upper bound in range");
+node_error(expp, "lower bound exceeds upper bound in range");
 				return rem_set(set);
 			}
 			
@@ -161,20 +175,21 @@ node_error(expp, "Lower bound exceeds upper bound in range");
 		return rem_set(set);
 	}
 	if (!TstCompat(tp, expp->nd_type)) {
-		node_error(expp, "Set element has incompatible type");
+		node_error(expp, "set element has incompatible type");
 		return rem_set(set);
 	}
 	if (expp->nd_class == Value) {
+		i = expp->nd_INT;
 	    	if ((tp->tp_fund != T_ENUMERATION &&
-		     (expp->nd_INT < tp->sub_lb || expp->nd_INT > tp->sub_ub))
+		     (i < tp->sub_lb || i > tp->sub_ub))
 		   ||
 		    (tp->tp_fund == T_ENUMERATION &&
-		     (expp->nd_INT < 0 || expp->nd_INT > tp->enm_ncst))
+		     (i < 0 || i > tp->enm_ncst))
 		   ) {
-			node_error(expp, "Set element out of range");
+			node_error(expp, "set element out of range");
 			return rem_set(set);
 		}
-		if (*set) (*set)[expp->nd_INT/wrd_bits] |= (1 << (expp->nd_INT%wrd_bits));
+		if (*set) (*set)[i/wrd_bits] |= (1 << (i%wrd_bits));
 	}
 	return 1;
 }
@@ -207,8 +222,8 @@ getarg(argp, bases)
 	if (!chk_expr(argp->nd_left)) return 0;
 	tp = argp->nd_left->nd_type;
 	if (tp->tp_fund == T_SUBRANGE) tp = tp->next;
-	if (!(tp->tp_fund & bases)) {
+	if (bases && !(tp->tp_fund & bases)) {
-		node_error(argp, "Unexpected type");
+		node_error(argp, "unexpected type");
 		return 0;
 	}
 	return argp;
@@ -226,7 +241,7 @@ getname(argp, kinds)
 	findname(argp->nd_left);
 	assert(argp->nd_left->nd_class == Def);
 	if (!(argp->nd_left->nd_def->df_kind & kinds)) {
-		node_error(argp, "Unexpected type");
+		node_error(argp, "unexpected type");
 		return 0;
 	}
 	return argp;
@@ -243,6 +258,8 @@ chk_call(expp)
 	register struct node *left;
 	register struct node *arg;
 
+	/* First, get the name of the function or procedure
+	*/
 	expp->nd_type = error_type;
 	left = expp->nd_left;
 	findname(left);
@@ -250,18 +267,18 @@ chk_call(expp)
 	if (left->nd_type == error_type) return 0;
 	if (left->nd_class == Def &&
 	    (left->nd_def->df_kind & (D_HTYPE|D_TYPE|D_HIDDEN))) {
-		/* A type cast. This is of course not portable.
+		/* It was a type cast. This is of course not portable.
 		   No runtime action. Remove it.
 		*/
 		arg = expp->nd_right;
 		if ((! arg) || arg->nd_right) {
-node_error(expp, "Only one parameter expected in type cast");
+node_error(expp, "only one parameter expected in type cast");
 			return 0;
 		}
 		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, "size of type in type cast does not match size of operand");
 			return 0;
 		}
 		arg->nd_type = left->nd_type;
@@ -285,7 +302,7 @@ node_error(expp, "Size of type in type cast does not match size of operand");
 			/* A standard procedure
 			*/
 			assert(left->nd_class == Def);
-DO_DEBUG(3, debug("Standard name \"%s\", %d", 
+DO_DEBUG(3, debug("standard name \"%s\", %d", 
 left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname));
 			switch(left->nd_def->df_value.df_stdname) {
 			case S_ABS:
@@ -297,6 +314,7 @@ left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname));
 					cstcall(expp, S_ABS);
 				}
 				break;
+
 			case S_CAP:
 				arg = getarg(arg, T_CHAR);
 				expp->nd_type = char_type;
@@ -306,6 +324,7 @@ left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname));
 					cstcall(expp, S_CAP);
 				}
 				break;
+
 			case S_CHR:
 				arg = getarg(arg, T_INTORCARD);
 				expp->nd_type = char_type;
@@ -314,11 +333,13 @@ left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname));
 					cstcall(expp, S_CHR);
 				}
 				break;
+
 			case S_FLOAT:
 				arg = getarg(arg, T_INTORCARD);
 				expp->nd_type = real_type;
 				if (!arg) return 0;
 				break;
+
 			case S_HIGH:
 				arg = getarg(arg, T_ARRAY);
 				if (!arg) return 0;
@@ -331,6 +352,7 @@ left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname));
 				}
 				else	cstcall(expp, S_MAX);
 				break;
+
 			case S_MAX:
 			case S_MIN:
 				arg = getarg(arg, T_DISCRETE);
@@ -338,6 +360,7 @@ left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname));
 				expp->nd_type = arg->nd_left->nd_type;
 				cstcall(expp,left->nd_def->df_value.df_stdname);
 				break;
+
 			case S_ODD:
 				arg = getarg(arg, T_INTORCARD);
 				if (!arg) return 0;
@@ -346,6 +369,7 @@ left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname));
 					cstcall(expp, S_ODD);
 				}
 				break;
+
 			case S_ORD:
 				arg = getarg(arg, T_DISCRETE);
 				if (!arg) return 0;
@@ -354,6 +378,7 @@ left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname));
 					cstcall(expp, S_ORD);
 				}
 				break;
+
 			case S_TSIZE:	/* ??? */
 			case S_SIZE:
 				arg = getname(arg, D_FIELD|D_VARIABLE|D_TYPE|D_HIDDEN|D_HTYPE);
@@ -361,11 +386,13 @@ left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname));
 				if (!arg) return 0;
 				cstcall(expp, S_SIZE);
 				break;
+
 			case S_TRUNC:
 				arg = getarg(arg, T_REAL);
 				if (!arg) return 0;
 				expp->nd_type = card_type;
 				break;
+
 			case S_VAL: {
 				struct type *tp;
 
@@ -388,11 +415,13 @@ left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname));
 				}
 				break;
 				}
+
 			case S_ADR:
 				arg = getname(arg, D_VARIABLE|D_FIELD|D_PROCEDURE);
 				expp->nd_type = address_type;
 				if (!arg) return 0;
 				break;
+
 			case S_DEC:
 			case S_INC:
 				expp->nd_type = 0;
@@ -403,9 +432,11 @@ left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname));
 					if (!arg) return 0;
 				}
 				break;
+
 			case S_HALT:
 				expp->nd_type = 0;
 				break;
+
 			case S_EXCL:
 			case S_INCL: {
 				struct type *tp;
@@ -421,11 +452,12 @@ node_error(arg, "EXCL and INCL expect a SET parameter");
 				arg = getarg(arg, T_DISCRETE);
 				if (!arg) return 0;
 				if (!TstCompat(tp->next, arg->nd_left->nd_type)) {
-					node_error(arg, "Unexpected type");
+					node_error(arg, "unexpected type");
 					return 0;
 				}
 				break;
 				}
+
 			default:
 				assert(0);
 			}
@@ -436,14 +468,51 @@ node_error(arg, "EXCL and INCL expect a SET parameter");
 			}
 			return 1;
 		}
-		/* Here, we have found a real procedure call
+		/* Here, we have found a real procedure call. The left hand
+		   side may also represent a procedure variable.
 		*/
-		return 1;
+		return chk_proccall(expp);
 	}
 	node_error(expp->nd_left, "procedure, type, or function expected");
 	return 0;
 }
 
+chk_proccall(expp)
+	struct node *expp;
+{
+	/*	Check a procedure call
+	*/
+	register struct node *left = expp->nd_left;
+	register struct node *arg;
+	register struct paramlist *param;
+
+	expp->nd_type = left->nd_type->next;
+	param = left->nd_type->prc_params;
+	arg = expp;
+
+	while (param) {
+		arg = getarg(arg, 0);
+		if (!arg) return 0;
+		if (param->par_var &&
+		    ! TstCompat(param->par_type, arg->nd_left->nd_type)) {
+node_error(arg->nd_left, "type incompatibility in var parameter");
+			return 0;
+		}
+		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;
+}
+
 findname(expp)
 	register struct node *expp;
 {
@@ -471,7 +540,7 @@ findname(expp)
 		}
 		else if (tp->tp_fund != T_RECORD) {
 			/* This is also true for modules */
-			node_error(expp,"Illegal selection");
+			node_error(expp,"illegal selection");
 			df = ill_df;
 		}
 		else df = lookup(expp->nd_right->nd_IDF, tp->rec_scope);
@@ -614,16 +683,19 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R
 				cstbin(expp);
 			}
 			return 1;
+
 		case T_SET:
 			if (expp->nd_left->nd_class == Set &&
 			    expp->nd_right->nd_class == Set) {
 				cstset(expp);
 			}
 			/* Fall through */
+
 		case T_REAL:
 			return 1;
 		}
 		break;
+
 	case '/':
 		switch(tpl->tp_fund) {
 		case T_SET:
@@ -632,10 +704,12 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R
 				cstset(expp);
 			}
 			/* Fall through */
+
 		case T_REAL:
 			return 1;
 		}
 		break;
+
 	case DIV:
 	case MOD:
 		if (tpl->tp_fund & T_INTORCARD) {
@@ -646,6 +720,7 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R
 			return 1;
 		}
 		break;
+
 	case OR:
 	case AND:
 		if (tpl == bool_type) {
@@ -657,6 +732,7 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R
 		}
 		errval = 3;
 		break;
+
 	case '=':
 	case '#':
 	case GREATEREQUAL:
@@ -673,6 +749,7 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R
 				cstset(expp);
 			}
 			return 1;
+
 		case T_INTEGER:
 		case T_CARDINAL:
 		case T_ENUMERATION:	/* includes boolean */
@@ -683,24 +760,29 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R
 				cstbin(expp);
 			}
 			return 1;
+
 		case T_POINTER:
 			if (!(expp->nd_symb == '=' || expp->nd_symb == '#')) {
 				break;
 			}
 			/* Fall through */
+
 		case T_REAL:
 			return 1;
 		}
+
 	default:
 		assert(0);
 	}
 	switch(errval) {
 	case 1:
-		node_error(expp,"Operator \"%s\": illegal operand type(s)", symbol2str(expp->nd_symb));
+		node_error(expp,"operator \"%s\": illegal operand type(s)", symbol2str(expp->nd_symb));
 		break;
+
 	case 3:
 		node_error(expp, "BOOLEAN type(s) expected");
 		break;
+
 	default:
 		assert(0);
 	}
@@ -727,6 +809,7 @@ chk_uoper(expp)
 			return 1;
 		}
 		break;
+
 	case '-':
 		if (tpr->tp_fund & T_INTORCARD) {
 			if (expp->nd_right->nd_class == Value) {
@@ -747,6 +830,7 @@ chk_uoper(expp)
 			return 1;
 		}
 		break;
+
 	case NOT:
 		if (tpr == bool_type) {
 			if (expp->nd_right->nd_class == Value) {
@@ -755,10 +839,12 @@ chk_uoper(expp)
 			return 1;
 		}
 		break;
+
 	case '^':
 		if (tpr->tp_fund != T_POINTER) break;
 		expp->nd_type = tpr->next;
 		return 1;
+
 	default:
 		assert(0);
 	}

lang/m2/comp/declar.g

@@ -14,16 +14,24 @@ static char *RcsId = "$Header$";
 #include	"scope.h"
 #include	"node.h"
 #include	"misc.h"
+#include	"main.h"
 
 static int	proclevel = 0;	/* nesting level of procedures */
+char *		sprint();
 }
 
 ProcedureDeclaration
 {
 	struct def *df;
+	char buf[256];
 } :
 	ProcedureHeading(&df, D_PROCEDURE)
 			{ df->prc_level = proclevel++;
+			  if (DefinitionModule) {
+				C_exp(sprint(buf, "%s_%s",
+						df->df_scope->sc_name,
+						df->df_idf->id_text));
+			  }
 			}
 	';' block(&(df->prc_body)) IDENT
 			{ match_id(dot.TOK_IDF, df->df_idf);

lang/m2/comp/def.H

@@ -14,8 +14,13 @@ struct module {
 struct variable {
 	arith va_off;		/* address or offset of variable */
 	char va_addrgiven;	/* an address was given in the program */
+	char va_noreg;		/* may not be in a register */
+	short va_number;	/* number of this variable in definition module
+				*/
 #define var_off		df_value.df_variable.va_off
 #define var_addrgiven	df_value.df_variable.va_addrgiven
+#define var_noreg	df_value.df_variable.va_noreg
+#define var_number	df_value.df_variable.va_number
 };
 
 struct constant {
@@ -43,13 +48,16 @@ struct field {
 
 struct dfproc {
 	struct scope *pr_scope;	/* scope of procedure */
-	int pr_level;		/* depth level of this procedure */
+	short pr_level;		/* depth level of this procedure */
-	arith pr_nbpar;		/* Number of bytes parameters */
+	short pr_number;	/* number of this procedure in definition module
+				*/
+	arith pr_nbpar;		/* number of bytes parameters */
 	struct node *pr_body;	/* body of this procedure */
 #define prc_scope	df_value.df_proc.pr_scope
 #define prc_level	df_value.df_proc.pr_level
 #define prc_nbpar	df_value.df_proc.pr_nbpar
 #define prc_body	df_value.df_proc.pr_body
+#define prc_number	df_value.df_proc.pr_number
 };
 
 struct import {

lang/m2/comp/def.c

@@ -22,6 +22,32 @@ static struct def illegal_def =
 
 struct def *ill_df = &illegal_def;
 
+struct def *
+MkDef(id, scope, kind)
+	struct idf *id;
+	struct scope *scope;
+{
+	/*	Create a new definition structure in scope "scope", with
+		id "id" and kind "kind".
+	*/
+	register struct def *df;
+
+	df = new_def();
+	df->df_flags = 0;
+	df->df_idf = id;
+	df->df_scope = scope;
+	df->df_kind = kind;
+	df->df_type = 0;
+	df->next = id->id_def;
+	id->id_def = df;
+
+	/* enter the definition in the list of definitions in this scope
+	*/
+	df->df_nextinscope = scope->sc_def;
+	scope->sc_def = df;
+	return df;
+}
+
 struct def *
 define(id, scope, kind)
 	register struct idf *id;
@@ -85,19 +111,7 @@ error("identifier \"%s\" already declared", id->id_text);
 		}
 		return df;
 	}
-	df = new_def();
+	return MkDef(id, scope, kind);
-	df->df_flags = 0;
-	df->df_idf = id;
-	df->df_scope = scope;
-	df->df_kind = kind;
-	df->df_type = 0;
-	df->next = id->id_def;
-	id->id_def = df;
-
-	/* enter the definition in the list of definitions in this scope */
-	df->df_nextinscope = scope->sc_def;
-	scope->sc_def = df;
-	return df;
 }
 
 struct def *

lang/m2/comp/enter.c

@@ -12,6 +12,7 @@ static char *RcsId = "$Header$";
 #include	"scope.h"
 #include	"LLlex.h"
 #include	"node.h"
+#include	"main.h"
 
 struct def *
 Enter(name, kind, type, pnam)
@@ -126,6 +127,13 @@ node_error(IdList->nd_left,"Illegal type for address");
 			df->var_off = off;
 			scope->sc_off = off;
 		}
+		else if (DefinitionModule) {
+			char buf[256];
+			char *sprint();
+
+			C_exa_dnam(sprint(buf,"%s_%s",df->df_scope->sc_name,
+						df->df_idf->id_text));
+		}
 		IdList = IdList->nd_right;
 	}
 }
@@ -137,17 +145,20 @@ lookfor(id, scope, give_error)
 {
 	/*	Look for an identifier in the visibility range started by
 		"scope".
-		If it is not defined, give an error message, and
+		If it is not defined, maybe give an error message, and
 		create a dummy definition.
 	*/
 	struct def *df;
 	register struct scope *sc = scope;
+	struct def *MkDef();
 
 	while (sc) {
 		df = lookup(id->nd_IDF, sc);
 		if (df) return df;
 		sc = nextvisible(sc);
 	}
+
 	if (give_error) id_not_declared(id);
-	return define(id->nd_IDF, scope, D_ERROR);
+
+	return MkDef(id->nd_IDF, scope, D_ERROR);
 }

lang/m2/comp/error.c

@@ -11,6 +11,7 @@ static char *RcsId = "$Header$";
 #include	<em_arith.h>
 
 #include	"errout.h"
+#include	"debug.h"
 
 #include	"input.h"
 #include	"f_info.h"

lang/m2/comp/expression.g

@@ -183,10 +183,15 @@ factor(struct node **p;)
 | %default
 	number(p)
 |
-	STRING		{ *p = MkNode(Value, NULLNODE, NULLNODE, &dot);
+	STRING		{
+			  *p = MkNode(Value, NULLNODE, NULLNODE, &dot);
 			  if (dot.TOK_SLE == 1) {
-				dot.TOK_INT = *(dot.TOK_STR);
+				int i;
-				(*p)->nd_type = char_type;
+
+				i = *(dot.TOK_STR) & 0377;
+				(*p)->nd_type = charc_type;
+				free(dot.TOK_STR);
+				dot.TOK_INT = i;
 			  }
 			  else	(*p)->nd_type = string_type;
 			}

lang/m2/comp/main.c

@@ -40,23 +40,24 @@ main(argc, argv)
 			Nargv[Nargc++] = *argv++;
 	}
 	Nargv[Nargc] = 0;	/* terminate the arg vector	*/
-	if (Nargc != 2) {
+	if (Nargc < 2) {
-		fprint(STDERR, "%s: Use one file argument\n", ProgName);
+		fprint(STDERR, "%s: Use a file argument\n", ProgName);
 		return 1;
 	}
 #ifdef DEBUG
-	print("Mod2 compiler -- Debug version\n");
+	print("MODULA-2 compiler -- Debug version\n");
-#endif DEBUG
 	DO_DEBUG(1, debug("Debugging level: %d", options['D']));
-	return !Compile(Nargv[1]);
+#endif DEBUG
+	return !Compile(Nargv[1], Nargv[2]);
 }
 
-Compile(src)
+Compile(src, dst)
-	char *src;
+	char *src, *dst;
 {
 	extern struct tokenname tkidf[];
 
 	DO_DEBUG(1, debug("Filename : %s", src));
+	DO_DEBUG(1, (!dst || debug("Targetfile: %s", dst)));
 	if (! InsertFile(src, (char **) 0, &src)) {
 		fprint(STDERR,"%s: cannot open %s\n", ProgName, src);
 		return 0;
@@ -77,8 +78,15 @@ Compile(src)
 	{
 		(void) open_scope(CLOSEDSCOPE);
 		GlobalScope = CurrentScope;
+		C_init(word_size, pointer_size);
+		if (! C_open(dst)) {
+			fatal("Could not open output file");
+		}
+		C_magic();
+		C_ms_emx(word_size, pointer_size);
 		CompUnit();
 	}
+	C_close();
 	if (err_occurred) return 0;
 	return 1;
 }
@@ -87,6 +95,7 @@ Compile(src)
 LexScan()
 {
 	register int symb;
+	char *symbol2str();
 
 	while ((symb = LLlex()) > 0) {
 		print(">>> %s ", symbol2str(symb));
@@ -171,6 +180,8 @@ init_DEFPATH()
 			if (*p) *p++ = '\0';
 		}
 	}
+	else DEFPATH[i++] = "";
+
 	DEFPATH[i] = 0;
 }
 

lang/m2/comp/program.g

@@ -20,6 +20,9 @@ static int DEFofIMPL = 0;	/* Flag indicating that we are currently
 				   implementation module currently being
 				   compiled
 				*/
+short nmcount = 0;		/* count names in definition modules in order
+				   to create suitable names in the object code
+				*/
 }
 /*
 	The grammar as given by Wirth is already almost LL(1); the
@@ -95,7 +98,7 @@ export(int def;)
 				Export(ExportList, QUALflag);
 			  }
 			  else {
-			  warning("export list in definition module ignored");
+node_warning(ExportList, "export list in definition module ignored");
 				FreeNode(ExportList);
 			  }
 			}
@@ -125,16 +128,20 @@ DefinitionModule
 {
 	register struct def *df;
 	struct idf *id;
+	int savnmcount = nmcount;
 } :
 	DEFINITION
 	MODULE IDENT	{ id = dot.TOK_IDF;
 			  df = define(id, GlobalScope, D_MODULE);
 			  if (!SYSTEMModule) open_scope(CLOSEDSCOPE);
 			  df->mod_scope = CurrentScope;
+			  CurrentScope->sc_name = id->id_text;
 			  df->df_type = standard_type(T_RECORD, 0, (arith) 0);
 			  df->df_type->rec_scope = df->mod_scope;
-			  DefinitionModule = 1;
+			  DefinitionModule++;
-			  DO_DEBUG(1, debug("Definition module \"%s\"", id->id_text));
+			  nmcount = 0;
+			  DO_DEBUG(1, debug("Definition module \"%s\" %d",
+					id->id_text, DefinitionModule));
 			}
 	';'
 	import(0)* 
@@ -158,8 +165,9 @@ DefinitionModule
 				df = df->df_nextinscope;
 			  }
 			  if (!SYSTEMModule) close_scope(SC_CHKFORW);
-			  DefinitionModule = 0;
+			  DefinitionModule--;
 			  match_id(id, dot.TOK_IDF);
+			  nmcount = savnmcount;
 			}
 	'.'
 ;
@@ -210,7 +218,6 @@ ProgramModule(int state;)
 			df = GetDefinitionModule(id);
 			CurrentScope = df->mod_scope;
 			DEFofIMPL = 0;
-		  	DefinitionModule = 0;
 		  }
 		  else {
 			df = define(id, CurrentScope, D_MODULE);

lang/m2/comp/scope.C

@@ -15,6 +15,7 @@ static char *RcsId = "$Header$";
 #include	"debug.h"
 
 struct scope *CurrentScope, *PervasiveScope, *GlobalScope;
+static int scp_level;
 
 /* STATICALLOCDEF "scope" */
 
@@ -26,6 +27,7 @@ open_scope(scopetype)
 
 	assert(scopetype == OPENSCOPE || scopetype == CLOSEDSCOPE);
 	sc->sc_scopeclosed = scopetype == CLOSEDSCOPE;
+	sc->sc_level = scp_level++;
 	sc->sc_forw = 0;
 	sc->sc_def = 0;
 	sc->sc_off = 0;
@@ -45,6 +47,7 @@ init_scope()
 	sc->sc_scopeclosed = 0;
 	sc->sc_forw = 0;
 	sc->sc_def = 0;
+	sc->sc_level = scp_level++;
 	sc->next = 0;
 	PervasiveScope = sc;
 	CurrentScope = sc;
@@ -197,6 +200,7 @@ close_scope(flag)
 		Reverse(&(sc->sc_def));
 	}
 	CurrentScope = sc->next;
+	scp_level = CurrentScope->sc_level;
 }
 
 #ifdef DEBUG

lang/m2/comp/scope.h

@@ -15,9 +15,11 @@
 struct scope {
 	struct scope *next;
 	struct forwards *sc_forw;
+	char *sc_name;		/* name of this scope */
 	struct def *sc_def;	/* list of definitions in this scope */
 	arith sc_off;		/* offsets of variables in this scope */
 	char sc_scopeclosed;	/* flag indicating closed or open scope */
+	int sc_level;		/* level of this scope */
 };
 
 extern struct scope

lang/m2/comp/type.H

@@ -88,6 +88,7 @@ struct type	{
 extern struct type
 	*bool_type,
 	*char_type,
+	*charc_type,
 	*int_type,
 	*card_type,
 	*longint_type,

lang/m2/comp/type.c

@@ -40,6 +40,7 @@ arith
 struct type
 	*bool_type,
 	*char_type,
+	*charc_type,
 	*int_type,
 	*card_type,
 	*longint_type,
@@ -134,6 +135,8 @@ init_types()
 
 	char_type = standard_type(T_CHAR, 1, (arith) 1);
 	char_type->enm_ncst = 256;
+	charc_type = standard_type(T_CHAR, 1, (arith) 1);
+	charc_type->enm_ncst = 256;
 	bool_type = standard_type(T_ENUMERATION, 1, (arith) 1);
 	bool_type->enm_ncst = 2;
 	int_type = standard_type(T_INTEGER, int_align, int_size);

lang/m2/comp/typequiv.c

@@ -111,3 +111,27 @@ TstCompat(tp1, tp2)
 		)
 	;
 }
+
+int TstAssCompat(tp1, tp2)
+	struct type *tp1, *tp2;
+{
+	/*	Test if two types are assignment compatible.
+	*/
+	if (TstCompat(tp1, tp2)) return 1;
+
+	if (tp1->tp_fund == T_SUBRANGE) tp1 = tp1->next;
+	if (tp2->tp_fund == T_SUBRANGE) tp2 = tp2->next;
+	if ((tp1->tp_fund & (T_INTEGER|T_CARDINAL)) &&
+	    (tp2->tp_fund & (T_INTEGER|T_CARDINAL))) return 1;
+	if (tp1 == char_type && tp2 == charc_type) return 1;
+	if (tp1->tp_fund == T_ARRAY && 
+	    (tp2 == charc_type || tp2 == string_type)) {
+		/* Unfortunately the length of the string is not
+		   available here, so this must be tested somewhere else (???)
+		*/
+	    	tp1 = tp1->arr_elem;
+		if (tp1->tp_fund == T_SUBRANGE) tp1 = tp1->next;
+		return tp1 == char_type;
+	}
+	return 0;
+}