newer version

lang/m2/comp/Makefile

@@ -44,8 +44,8 @@ main:	$(OBJ) Makefile
 clean:
 	rm -f $(OBJ) $(GENFILES) LLfiles 
 
-lint:	LLfiles lintlist
+lint:	LLfiles hfiles
-	lint $(INCLUDES) `cat lintlist`
+	lint $(INCLUDES) -DNORCSID `sources $(OBJ)`
 
 tokenfile.g:	tokenname.c make.tokfile
 	make.tokfile <tokenname.c >tokenfile.g
@@ -79,11 +79,11 @@ depend:
 	make.allocd < $< > $@
 
 #AUTOAUTOAUTOAUTOAUTOAUTOAUTOAUTO
-LLlex.o: LLlex.h Lpars.h class.h const.h f_info.h idf.h idfsize.h input.h inputtype.h numsize.h strsize.h type.h
+LLlex.o: LLlex.h Lpars.h class.h const.h debug.h f_info.h idf.h idfsize.h input.h inputtype.h numsize.h strsize.h type.h
 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 ndirs.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 ndir.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
@@ -92,17 +92,18 @@ type.o: LLlex.h const.h debug.h def.h idf.h maxset.h node.h target_sizes.h type.
 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 main.h node.h scope.h type.h
+enter.o: LLlex.h debug.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 main.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
+cstoper.o: LLlex.h Lpars.h debug.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 main.h ndir.h type.h
 walk.o: LLlex.h Lpars.h debug.h def.h main.h node.h scope.h type.h
+casestat.o: LLlex.h Lpars.h debug.h density.h node.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 main.h misc.h node.h scope.h type.h
+declar.o: LLlex.h Lpars.h debug.h def.h idf.h main.h misc.h node.h scope.h type.h
-expression.o: LLlex.h Lpars.h const.h debug.h def.h idf.h node.h scope.h type.h
+expression.o: LLlex.h Lpars.h const.h debug.h def.h idf.h node.h type.h
 statement.o: LLlex.h Lpars.h def.h idf.h node.h scope.h type.h
 Lpars.o: Lpars.h

lang/m2/comp/casestat.C

@@ -18,8 +18,6 @@ static char *RcsId = "$Header$";
 
 #include	"density.h"
 
-/* STATICALLOCDEF "caselist" */
-
 struct switch_hdr	{
 	struct switch_hdr *next;
 	label sh_break;
@@ -102,7 +100,7 @@ CaseCode(nd, exitlabel)
 	tablabel = data_label();	/* the rom must have a label	*/
 	C_df_dlb(tablabel);
 	if (sh->sh_default) C_rom_ilb(sh->sh_default);
-	else C_rom_ucon((arith) 0, pointer_size);
+	else C_rom_ucon("0", pointer_size);
 	if (compact(sh->sh_nrofentries, sh->sh_lowerbd, sh->sh_upperbd)) {
 		/* CSA */
 
@@ -253,8 +251,7 @@ AddOneCase(sh, node, lbl)
 		*/
 		if (c1)	{
 			if (c1->ce_value == ce->ce_value)	{
-				node_error("multiple case entry for value %ld",
+node_error(node, "multiple case entry for value %ld", ce->ce_value);
-					ce->ce_value);
 				free_case_entry(ce);
 				return 0;
 			}

lang/m2/comp/chk_expr.c

@@ -448,7 +448,7 @@ chk_designator(expp, flag)
 		assert(expp->nd_right->nd_class == Name);
 
 		if (! chk_designator(expp->nd_left,
-				     (flag|HASSELECTORS)&DESIGNATOR)) return 0;
+				     (flag|HASSELECTORS))) return 0;
 
 		tp = expp->nd_left->nd_type;
 
@@ -633,7 +633,7 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R
 	case '*':
 		switch(tpl->tp_fund) {
 		case T_POINTER:
-			if (tpl != address_type) break;
+			if (! chk_address(tpl, tpr)) break;
 			/* Fall through */
 		case T_INTEGER:
 		case T_CARDINAL:
@@ -669,7 +669,13 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R
 
 	case DIV:
 	case MOD:
-		if ((tpl->tp_fund & T_INTORCARD) || tpl == address_type) {
+		switch(tpl->tp_fund) {
+		case T_POINTER:
+			if (! chk_address(tpl, tpr)) break;
+			/* Fall through */
+		case T_INTEGER:
+		case T_CARDINAL:
+		case T_INTORCARD:
 			if (left->nd_class==Value && right->nd_class==Value) {
 				cstbin(expp);
 			}
@@ -718,7 +724,8 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R
 			return 1;
 
 		case T_POINTER:
-			if (expp->nd_symb == '=' ||
+			if (chk_address(tpl, tpr) ||
+			    expp->nd_symb == '=' ||
 			    expp->nd_symb == UNEQUAL ||
 			    expp->nd_symb == '#') return 1;
 			break;
@@ -745,6 +752,22 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R
 	return 0;
 }
 
+int
+chk_address(tpl, tpr)
+	register struct type *tpl, *tpr;
+{
+	
+	if (tpl == address_type) {
+		return tpr == address_type || tpr->tp_fund != T_POINTER;
+	}
+
+	if (tpr == address_type) {
+		return tpl->tp_fund != T_POINTER;
+	}
+
+	return 0;
+}
+
 int
 chk_uoper(expp)
 	register struct node *expp;
@@ -769,6 +792,9 @@ chk_uoper(expp)
 
 	case '-':
 		if (tpr->tp_fund & T_INTORCARD) {
+			if (tpr == intorcard_type) {
+				expp->nd_type = int_type;
+			}
 			if (right->nd_class == Value) {
 				cstunary(expp);
 			}

lang/m2/comp/declar.g

@@ -56,6 +56,12 @@ ProcedureHeading(struct def **pdf; int type;)
 	PROCEDURE IDENT
 		{
 		  df = DeclProc(type);
+		  if (proclevel) {
+			/* Room for static link
+			*/
+			df->prc_nbpar = pointer_size;
+		  }
+		  else	df->prc_nbpar = 0;
 		}
 	FormalParameters(type == D_PROCEDURE, &params, &tp, &(df->prc_nbpar))?
 		{

lang/m2/comp/def.c

@@ -477,7 +477,6 @@ DeclProc(type)
 			strcpy(CurrentScope->sc_name, buf);
 			C_inp(buf);
 		}
-		df->prc_nbpar = 0;
 	}
 
 	return df;

lang/m2/comp/walk.c

@@ -25,8 +25,6 @@ static char *RcsId = "$Header$";
 extern arith	align();
 static int	prclev = 0;
 static label	instructionlabel;
-static label	datalabel = 1;
-static label	return_label;
 static char	return_expr_occurred;
 static struct type *func_type;
 
@@ -39,7 +37,9 @@ text_label()
 label
 data_label()
 {
-	return datalabel++;
+	static label	datalabel = 0;
+
+	return ++datalabel;
 }
 
 WalkModule(module)
@@ -89,14 +89,13 @@ WalkModule(module)
 	   this module.
 	*/
 	CurrentScope->sc_off = 0;
-	instructionlabel = 1;
+	instructionlabel = 2;
-	return_label = instructionlabel++;
 	func_type = 0;
 	C_pro_narg(CurrentScope->sc_name);
 	MkCalls(CurrentScope->sc_def);
 	WalkNode(module->mod_body, (label) 0);
-	C_df_ilb(return_label);
+	C_df_ilb((label) 1);
-	C_ret((label) 0);
+	C_ret(0);
 	C_end(align(-CurrentScope->sc_off, word_align));
 
 	CurrVis = vis;
@@ -121,15 +120,20 @@ WalkProcedure(procedure)
 	/* generate calls to initialization routines of modules defined within
 	   this procedure
 	*/
-	return_label = 1;
+	MkCalls(CurrentScope->sc_def);
+	return_expr_occurred = 0;
 	instructionlabel = 2;
 	func_type = procedure->df_type->next;
-	MkCalls(CurrentScope->sc_def);
 	WalkNode(procedure->prc_body, (label) 0);
-	C_df_ilb(return_label);
+	C_df_ilb((label) 1);
-	if (func_type) C_ret((arith) align(func_type->tp_size, word_align));
+	if (func_type) {
-	else C_ret((arith) 0);
+		if (! return_expr_occurred) {
-	C_end(align(-CurrentScope->sc_off, word_size));
+node_error(procedure->prc_body,"function procedure does not return a value");
+		}
+		C_ret((int) align(func_type->tp_size, word_align));
+	}
+	else	C_ret(0);
+	C_end((int) align(-CurrentScope->sc_off, word_align));
 	CurrVis = vis;
 	prclev--;
 }
@@ -195,6 +199,12 @@ WalkStat(nd, lab)
 	register struct node *left = nd->nd_left;
 	register struct node *right = nd->nd_right;
 
+	if (!nd) {
+		/* Empty statement
+		*/
+		return;
+	}
+
 	if (nd->nd_class == Call) {
 		if (chk_call(nd)) CodeCall(nd);
 		return;
@@ -204,8 +214,8 @@ WalkStat(nd, lab)
 
 	switch(nd->nd_symb) {
 	case BECOMES:
-		WalkDesignator(left);
 		WalkExpr(right);
+		WalkDesignator(left);	/* May we do it in this order??? */
 
 		if (! TstAssCompat(left->nd_type, right->nd_type)) {
 			node_error(nd, "type incompatibility in assignment");
@@ -318,7 +328,7 @@ node_error(right, "type incompatibility in RETURN statement");
 			}
 			return_expr_occurred = 1;
 		}
-		C_bra(return_label);
+		C_bra((label) 1);
 		break;
 
 	default: