fixes, added some standard functions to handle LONGREAL, LONGINT

lang/m2/comp/.distr

@@ -0,0 +1,62 @@
+LLlex.c
+LLlex.h
+LLmessage.c
+Makefile
+Parameters
+Resolve
+SYSTEM.h
+Version.c
+casestat.C
+char.tab
+chk_expr.c
+chk_expr.h
+class.h
+code.c
+const.h
+cstoper.c
+debug.h
+declar.g
+def.H
+def.c
+defmodule.c
+desig.c
+desig.h
+em_m2.6
+enter.c
+error.c
+expression.g
+f_info.h
+idf.c
+idf.h
+input.c
+input.h
+lookup.c
+main.c
+main.h
+make.allocd
+make.hfiles
+make.next
+make.tokcase
+make.tokfile
+misc.c
+misc.h
+modula-2.1
+nmclash.c
+node.H
+node.c
+options.c
+program.g
+scope.C
+scope.h
+standards.h
+statement.g
+tab.c
+tmpvar.C
+tokenname.c
+tokenname.h
+type.H
+type.c
+typequiv.c
+walk.c
+walk.h
+warning.h

lang/m2/comp/LLlex.c

@@ -59,7 +59,8 @@ SkipComment()
 			/* Foreign; This definition module has an
 			   implementation in another language.
 			   In this case, don't generate prefixes in front
-			   of the names
+			   of the names. Also, don't generate call to
+			   initialization routine.
 			*/
 			ForeignFlag = 1;
 			break;
@@ -359,7 +360,7 @@ again:
 			have to read the number with the help of a rather
 			complex finite automaton.
 		*/
-		enum statetp {Oct,Hex,Dec,OctEndOrHex,End,OptReal,Real};
+		enum statetp {Oct,OptHex,Hex,Dec,OctEndOrHex,End,OptReal,Real};
 		register enum statetp state;
 		register int base;
 		register char *np = &buf[1];
@@ -390,7 +391,8 @@ again:
 					}
 					LoadChar(ch);
 				}
-				if (is_hex(ch)) state = Hex;
+				if (ch == 'D') state = OptHex;
+				else if (is_hex(ch)) state = Hex;
 				else if (ch == '.') state = OptReal;
 				else {
 					state = End;
@@ -400,6 +402,15 @@ again:
 				}
 				break;
 
+			case OptHex:
+				LoadChar(ch);
+				if (is_hex(ch)) {
+					if (np < &buf[NUMSIZE]) *np++ = 'D';
+					state = Hex;
+				}
+				else	state = End;
+				break;
+
 			case Hex:
 				while (is_hex(ch))	{
 					if (np < &buf[NUMSIZE]) *np++ = ch;
@@ -454,6 +465,9 @@ lexwarning(W_ORDINARY, "overflow in constant");
 lexwarning(W_ORDINARY, "character constant out of range");
 					}
 				}
+				else if (ch == 'D' && base == 10) {
+					toktype = longint_type;
+				}
 				else if (tk->TOK_INT>=0 &&
 					 tk->TOK_INT<=max_int) {
 					toktype = intorcard_type;
@@ -485,6 +499,8 @@ lexwarning(W_ORDINARY, "character constant out of range");
 		/* a real real constant */
 		if (np < &buf[NUMSIZE]) *np++ = '.';
 
+		toktype = real_type;
+
 		while (is_dig(ch)) {
 			/* 	Fractional part
 			*/
@@ -492,9 +508,15 @@ lexwarning(W_ORDINARY, "character constant out of range");
 			LoadChar(ch);
 		}
 
-		if (ch == 'E') {
+		if (ch == 'E' || ch == 'D') {
 			/*	Scale factor
 			*/
+			if (ch == 'D') {
+				toktype = longreal_type;
+				LoadChar(ch);
+				if (!(ch == '+' || ch == '-' || is_dig(ch)))
+					goto noscale;
+			}
 			if (np < &buf[NUMSIZE]) *np++ = 'E';
 			LoadChar(ch);
 			if (ch == '+' || ch == '-') {
@@ -514,6 +536,7 @@ lexwarning(W_ORDINARY, "character constant out of range");
 			}
 		}
 
+noscale:
 		*np++ = '\0';
 		if (ch == EOI) eofseen = 1;
 		else PushBack();
@@ -523,7 +546,6 @@ lexwarning(W_ORDINARY, "character constant out of range");
 			lexerror("floating constant too long");
 		}
 		else	tk->TOK_REL = Salloc(buf, (unsigned) (np - buf)) + 1;
-		toktype = real_type;
 		return tk->tk_symb = REAL;
 
 		/*NOTREACHED*/

lang/m2/comp/chk_expr.c

@@ -840,7 +840,7 @@ ChkUnOper(expp)
 
 	case '-':
 		if (tpr->tp_fund & T_INTORCARD) {
-			if (tpr == intorcard_type) {
+			if (tpr == intorcard_type || tpr == card_type) {
 				expp->nd_type = int_type;
 			}
 			if (right->nd_class == Value) {
@@ -849,7 +849,6 @@ ChkUnOper(expp)
 			return 1;
 		}
 		else if (tpr->tp_fund == T_REAL) {
-			expp->nd_type = tpr;
 			if (right->nd_class == Value) {
 				if (*(right->nd_REL) == '-') (right->nd_REL)++;
 				else (right->nd_REL)--;
@@ -939,11 +938,47 @@ ChkStandard(expp, left)
 		if (left->nd_class == Value) cstcall(expp, S_CHR);
 		break;
 
+	case S_FLOATD:
 	case S_FLOAT:
 		expp->nd_type = real_type;
+		if (std == S_FLOATD) expp->nd_type = longreal_type;
 		if (!(left = getarg(&arg, T_INTORCARD, 0, edf))) return 0;
 		break;
 
+	case S_LONG: {
+		struct type *tp;
+
+		if (!(left = getarg(&arg, 0, 0, edf))) {
+			return 0;
+		}
+		tp = BaseType(left->nd_type);
+		if (tp == int_type) expp->nd_type = longint_type;
+		else if (tp == real_type) expp->nd_type = longreal_type;
+		else {
+			expp->nd_type = error_type;
+			Xerror(left, "unexpected parameter type", edf);
+		}
+		if (left->nd_class == Value) cstcall(expp, S_LONG);
+		break;
+		}
+
+	case S_SHORT: {
+		struct type *tp;
+
+		if (!(left = getarg(&arg, 0, 0, edf))) {
+			return 0;
+		}
+		tp = BaseType(left->nd_type);
+		if (tp == longint_type) expp->nd_type = int_type;
+		else if (tp == longreal_type) expp->nd_type = real_type;
+		else {
+			expp->nd_type = error_type;
+			Xerror(left, "unexpected parameter type", edf);
+		}
+		if (left->nd_class == Value) cstcall(expp, S_SHORT);
+		break;
+		}
+
 	case S_HIGH:
 		if (!(left = getarg(&arg, T_ARRAY|T_STRING|T_CHAR, 0, edf))) {
 			return 0;
@@ -1053,8 +1088,10 @@ ChkStandard(expp, left)
 				  expp->nd_left->nd_def->df_idf->id_text);
 		break;
 
+	case S_TRUNCD:
 	case S_TRUNC:
 		expp->nd_type = card_type;
+		if (std == S_TRUNCD) expp->nd_type = longint_type;
 		if (!(left = getarg(&arg, T_REAL, 0, edf))) return 0;
 		break;
 

lang/m2/comp/code.c

@@ -456,11 +456,6 @@ CodeStd(nd)
 		RangeCheck(char_type, tp);
 		break;
 
-	case S_FLOAT:
-		CodePExpr(left);
-		CodeCoercion(tp, real_type);
-		break;
-
 	case S_HIGH:
 		assert(IsConformantArray(tp));
 		DoHIGH(left->nd_def);
@@ -493,9 +488,14 @@ CodeStd(nd)
 		CodePExpr(left);
 		break;
 
+	case S_TRUNCD:
 	case S_TRUNC:
+	case S_FLOAT:
+	case S_FLOATD:
+	case S_LONG:
+	case S_SHORT:
 		CodePExpr(left);
-		CodeCoercion(tp, card_type);
+		CodeCoercion(tp, nd->nd_type);
 		break;
 
 	case S_VAL:

lang/m2/comp/cstoper.c

@@ -386,14 +386,19 @@ cstcall(expp, call)
 		CutSize(expp);
 		break;
 
+	case S_LONG:
+	case S_SHORT: {
+		struct type *tp = expp->nd_type;
+
+		*expp = *expr;
+		expp->nd_type = tp;
+		break;
+		}
 	case S_CAP:
 		if (expr->nd_INT >= 'a' && expr->nd_INT <= 'z') {
-			expp->nd_INT = expr->nd_INT + ('A' - 'a');
+			expr->nd_INT = expr->nd_INT + ('A' - 'a');
 		}
-		else	expp->nd_INT = expr->nd_INT;
+		/* fall through */
-		CutSize(expp);
-		break;
-
 	case S_CHR:
 		expp->nd_INT = expr->nd_INT;
 		CutSize(expp);

lang/m2/comp/defmodule.c

@@ -34,7 +34,7 @@ long	sys_filesize();
 
 struct idf *DefId;
 
-STATIC char *
+char *
 getwdir(fn)
 	register char *fn;
 {
@@ -65,7 +65,6 @@ GetFile(name)
 	*/
 	char buf[15];
 	char *strncpy(), *strcat();
-	static char *WorkingDir = ".";
 
 	strncpy(buf, name, 10);
 	buf[10] = '\0';			/* maximum length */

lang/m2/comp/desig.c

@@ -31,7 +31,7 @@
 #include	"node.h"
 
 extern int	proclevel;
-struct desig	InitDesig = {DSG_INIT, 0, 0};
+struct desig	InitDesig = {DSG_INIT, 0, 0, 0};
 
 int	C_ste_dnam(), C_sde_dnam(), C_loe_dnam(), C_lde_dnam();
 int	C_stl(), C_sdl(), C_lol(), C_ldl();
@@ -54,6 +54,7 @@ static int (*ext_ld_and_str[2][2])() = {
 int
 DoLoadOrStore(ds, size, LoadOrStoreFlag)
 	register struct desig *ds;
+	arith size;
 {
 	int sz;
 
@@ -223,8 +224,8 @@ CodeMove(rhs, left, rtp)
 	switch(rhs->dsg_kind) {
 	case DSG_LOADED:
 		CodeDesig(left, lhs);
-		CodeAddress(lhs);
 		if (rtp->tp_fund == T_STRING) {
+			CodeAddress(lhs);
 			C_loc(rtp->tp_size);
 			C_loc(tp->tp_size);
 			C_cal("_StringAssign");
@@ -315,6 +316,7 @@ CodeMove(rhs, left, rtp)
 				lhs->dsg_offset = tmp;
 				lhs->dsg_name = 0;
 				lhs->dsg_kind = DSG_PFIXED;
+				lhs->dsg_def = 0;
 				C_stl(tmp);		/* address of lhs */
 			}
 			CodeValue(rhs, tp->tp_size, tp->tp_align);
@@ -347,6 +349,7 @@ CodeAddress(ds)
 			break;
 		}
 		C_lal(ds->dsg_offset);
+		if (ds->dsg_def) ds->dsg_def->df_flags |= D_NOREG;
 		break;
 		
 	case DSG_PFIXED:
@@ -489,7 +492,8 @@ CodeVarDesig(df, ds)
 		ds->dsg_kind = DSG_PFIXED;
 	}
 	else	ds->dsg_kind = DSG_FIXED;
-	ds->dsg_offset =df->var_off;
+	ds->dsg_offset = df->var_off;
+	ds->dsg_def = df;
 }
 
 CodeDesig(nd, ds)

lang/m2/comp/desig.h

@@ -40,6 +40,9 @@ struct desig {
 	char	*dsg_name;	/* name of global variable, used for
 				   FIXED and PFIXED
 				*/
+	struct def *dsg_def;	/* def structure associated with this
+				   designator, or 0
+				*/
 };
 
 /* The next structure describes the designator in a with-statement.

lang/m2/comp/expression.g

@@ -79,16 +79,16 @@ ConstExpression(struct node **pnd;)
 	 * Check that the expression is a constant expression and evaluate!
 	 */
 		{ nd = *pnd;
-		  DO_DEBUG(options['X'], print("CONSTANT EXPRESSION\n"));
+		  DO_DEBUG(options['C'], print("CONSTANT EXPRESSION\n"));
-		  DO_DEBUG(options['X'], PrNode(nd, 0));
+		  DO_DEBUG(options['C'], PrNode(nd, 0));
 
 		  if (ChkExpression(nd) &&
 		      ((nd)->nd_class != Set && (nd)->nd_class != Value)) {
 			error("constant expression expected");
 		  }
 
-		  DO_DEBUG(options['X'], print("RESULTS IN\n"));
+		  DO_DEBUG(options['C'], print("RESULTS IN\n"));
-		  DO_DEBUG(options['X'], PrNode(nd, 0));
+		  DO_DEBUG(options['C'], PrNode(nd, 0));
 		}
 ;
 

lang/m2/comp/f_info.h

@@ -18,3 +18,4 @@ struct f_info {
 extern struct f_info file_info;
 #define LineNumber file_info.f_lineno
 #define FileName file_info.f_filename
+#define WorkingDir file_info.f_workingdir

lang/m2/comp/main.c

@@ -74,6 +74,7 @@ Compile(src, dst)
 	char *src, *dst;
 {
 	extern struct tokenname tkidf[];
+	extern char *getwdir();
 
 	if (! InsertFile(src, (char **) 0, &src)) {
 		fprint(STDERR,"%s: cannot open %s\n", ProgName, src);
@@ -81,6 +82,7 @@ Compile(src, dst)
 	}
 	LineNumber = 1;
 	FileName = src;
+	WorkingDir = getwdir(src);
 	init_idf();
 	InitCst();
 	reserve(tkidf);
@@ -171,6 +173,10 @@ static struct stdproc {
 	{ "MAX",	S_MAX },
 	{ "MIN",	S_MIN },
 	{ "INCL",	S_INCL },
+	{ "LONG",	S_LONG },
+	{ "SHORT",	S_SHORT },
+	{ "TRUNCD",	S_TRUNCD },
+	{ "FLOATD",	S_FLOATD },
 	{ 0,		0 }
 };
 
@@ -246,3 +252,13 @@ cnt_scope, cnt_scopelist, cnt_tmpvar);
 print("\nNumber of lines read: %d\n", cntlines);
 }
 #endif
+
+No_Mem()
+{
+	fatal("out of memory");
+}
+
+C_failed()
+{
+	fatal("write failed");
+}

lang/m2/comp/node.c

@@ -84,7 +84,13 @@ printnode(nd, lvl)
 	register struct node *nd;
 {
 	indnt(lvl);
-	print("C: %d; T: %s\n", nd->nd_class, symbol2str(nd->nd_symb));
+	print("Class: %d; Symbol: %s\n", nd->nd_class, symbol2str(nd->nd_symb));
+	if (nd->nd_type) {
+		indnt(lvl);
+		print("Type: ");
+		DumpType(nd->nd_type);
+		print("\n");
+	}
 }
 
 PrNode(nd, lvl)

lang/m2/comp/standards.h

@@ -28,6 +28,10 @@
 #define S_VAL	17
 #define S_NEW	18
 #define S_DISPOSE 19
+#define S_LONG	20
+#define S_SHORT	21
+#define S_TRUNCD 22
+#define S_FLOATD 23
 
 /* Standard procedures and functions defined in the SYSTEM module ... */
 

lang/m2/comp/type.H

@@ -150,6 +150,7 @@ struct type
 #define bounded(tpx)		((tpx)->tp_fund & T_INDEX)
 #define complex(tpx)		((tpx)->tp_fund & (T_RECORD|T_ARRAY))
 #define WA(sz)			(align(sz, (int) word_size))
+#ifdef DEBUG
 #define ResultType(tpx)		(assert((tpx)->tp_fund == T_PROCEDURE),\
 					(tpx)->next)
 #define ParamList(tpx)		(assert((tpx)->tp_fund == T_PROCEDURE),\
@@ -160,6 +161,13 @@ struct type
 					(tpx)->next)
 #define PointedtoType(tpx)	(assert((tpx)->tp_fund == T_POINTER),\
 					(tpx)->next)
+#else DEBUG
+#define ResultType(tpx)		((tpx)->next)
+#define ParamList(tpx)		((tpx)->prc_params)
+#define IndexType(tpx)		((tpx)->next)
+#define ElementType(tpx)	((tpx)->next)
+#define PointedtoType(tpx)	((tpx)->next)
+#endif DEBUG
 #define BaseType(tpx)		((tpx)->tp_fund == T_SUBRANGE ? (tpx)->next : \
 					(tpx))
 #define	IsConstructed(tpx)	((tpx)->tp_fund & T_CONSTRUCTED)

lang/m2/comp/type.c

@@ -652,8 +652,7 @@ DumpType(tp)
 	print(" fund:");
 	switch(tp->tp_fund) {
 	case T_RECORD:
-		print("RECORD\n");
+		print("RECORD");
-		DumpScope(tp->rec_scope->sc_def);
 		break;
 	case T_ENUMERATION:
 		print("ENUMERATION; ncst:%d", tp->enm_ncst); break;

lang/m2/comp/typequiv.c

@@ -63,7 +63,7 @@ TstParEquiv(tp1, tp2)
 
 int
 TstProcEquiv(tp1, tp2)
-	register struct type *tp1, *tp2;
+	struct type *tp1, *tp2;
 {
 	/*	Test if two procedure types are equivalent. This routine
 		may also be used for the testing of assignment compatibility
@@ -105,31 +105,24 @@ TstCompat(tp1, tp2)
 
 	tp1 = BaseType(tp1);
 	tp2 = BaseType(tp2);
+	if (tp2 != intorcard_type &&
+	    (tp1 == intorcard_type || tp1 == address_type)) {
+		struct type *tmp = tp2;
+		
+		tp2 = tp1;
+		tp1 = tmp;
+	}
 
 	return	tp1 == tp2
-	    ||
-		(  tp1 == intorcard_type
-		&&
-		   (tp2 == int_type || tp2 == card_type || tp2 == address_type)
-		)
 	    ||
 		(  tp2 == intorcard_type
 		&&
 		   (tp1 == int_type || tp1 == card_type || tp1 == address_type)
 		)
-	    ||
-		(  tp1 == address_type
-		&& 
-	          (  tp2 == card_type
-		  || tp2->tp_fund == T_POINTER
-		  )
-		)
 	    ||
 		(  tp2 == address_type
 		&& 
-	          (  tp1 == card_type
+	          ( tp1 == card_type || tp1->tp_fund == T_POINTER)
-		  || tp1->tp_fund == T_POINTER
-		  )
 		)
 	;
 }
@@ -151,6 +144,9 @@ TstAssCompat(tp1, tp2)
 	if ((tp1->tp_fund & T_INTORCARD) &&
 	    (tp2->tp_fund & T_INTORCARD)) return 1;
 
+	if ((tp1->tp_fund == T_REAL) &&
+	    (tp2->tp_fund == T_REAL)) return 1;
+
 	if (tp1->tp_fund == T_PROCEDURE &&
 	    tp2->tp_fund == T_PROCEDURE) {
 		return TstProcEquiv(tp1, tp2);

lang/m2/comp/walk.c

@@ -141,8 +141,8 @@ WalkModule(module)
 	}
 	MkCalls(sc->sc_def);
 	proclevel++;
-	DO_DEBUG(options['X'], PrNode(module->mod_body, 0));
 	WalkNode(module->mod_body, NO_EXIT_LABEL);
+	DO_DEBUG(options['X'], PrNode(module->mod_body, 0));
 	C_df_ilb(RETURN_LABEL);
 	EndPriority();
 	C_ret((arith) 0);
@@ -293,8 +293,8 @@ WalkProcedure(procedure)
 
 	text_label = 1;		/* label at end of procedure */
 
-	DO_DEBUG(options['X'], PrNode(procedure->prc_body, 0));
 	WalkNode(procedure->prc_body, NO_EXIT_LABEL);
+	DO_DEBUG(options['X'], PrNode(procedure->prc_body, 0));
 	C_df_ilb(RETURN_LABEL);	/* label at end */
 	tp = func_type;
 	if (func_res_label) {