From c3b3faf7a4ca0268c98d2bafc7aadab088c82b02 Mon Sep 17 00:00:00 2001
From: ceriel <none@none>
Date: Tue, 19 Dec 1989 09:40:25 +0000
Subject: [PATCH] Added support for constant floating point expressions

---
 lang/m2/comp/.distr      |  1 +
 lang/m2/comp/LLlex.c     | 15 ++++---
 lang/m2/comp/LLlex.h     |  7 +++-
 lang/m2/comp/LLmessage.c |  4 +-
 lang/m2/comp/Makefile    | 38 ++++++++++++++---
 lang/m2/comp/chk_expr.c  | 76 ++++++++++++++++++++++++++++++----
 lang/m2/comp/code.c      |  8 +++-
 lang/m2/comp/cstoper.c   | 89 ++++++++++++++++++++++++++++++++++++++++
 lang/m2/comp/debug.h     |  2 +
 lang/m2/comp/main.c      |  2 +-
 lang/m2/comp/node.H      |  3 +-
 lang/m2/comp/real.H      | 19 +++++++++
 lang/m2/comp/type.c      |  8 ++--
 13 files changed, 243 insertions(+), 29 deletions(-)
 create mode 100644 lang/m2/comp/real.H

diff --git a/lang/m2/comp/.distr b/lang/m2/comp/.distr
index 1be7c297f..bcd28f6dc 100644
--- a/lang/m2/comp/.distr
+++ b/lang/m2/comp/.distr
@@ -48,6 +48,7 @@ node.c
 options.c
 options
 program.g
+real.H
 scope.C
 scope.h
 standards.h
diff --git a/lang/m2/comp/LLlex.c b/lang/m2/comp/LLlex.c
index 895904943..7818b0b8c 100644
--- a/lang/m2/comp/LLlex.c
+++ b/lang/m2/comp/LLlex.c
@@ -42,6 +42,7 @@ extern int	cntlines;
 #endif
 
 extern char	options[];
+extern int	flt_status;
 
 STATIC
 SkipComment()
@@ -391,10 +392,9 @@ again:
 		enum statetp {Oct,OptHex,Hex,Dec,OctEndOrHex,End,OptReal,Real};
 		register enum statetp state;
 		register int base = 8;
-		register char *np = &buf[1];
+		register char *np = &buf[0];
 					/* allow a '-' to be added	*/
 
-		buf[0] = '-';
 		*np++ = ch;
 		state = is_oct(ch) ? Oct : Dec;
 		LoadChar(ch);
@@ -489,7 +489,7 @@ again:
 					*/
 					arith ubound = max_int[sizeof(arith)]
 							/ (base >> 1);
-					np = &buf[1];
+					np = &buf[0];
 					while (*np == '0') np++;
 					tk->TOK_INT = 0;
 					while (*np) {
@@ -613,12 +613,17 @@ lexwarning(W_ORDINARY, "overflow in constant");
 		*np++ = '\0';
 		PushBack();
 
+		tk->tk_data.tk_real = new_real();
 		if (np >= &buf[NUMSIZE]) {
-			tk->TOK_REL = Salloc("-0.0", 5)+1;
+			tk->TOK_REAL = Salloc("0.0", 4);
 			lexerror("real constant too long");
 		}
-		else	tk->TOK_REL = Salloc(buf, (unsigned) (np - buf)) + 1;
+		else	tk->TOK_REAL = Salloc(buf, (unsigned) (np - buf));
 		CheckForLet();
+		flt_str2flt(tk->TOK_REAL, &(tk->TOK_RVAL));
+		if (flt_status == FLT_OVFL) {
+lexwarning(W_ORDINARY, "overflow in floating point constant");
+		}
 		return tk->tk_symb = REAL;
 
 		/*NOTREACHED*/
diff --git a/lang/m2/comp/LLlex.h b/lang/m2/comp/LLlex.h
index 3d7f44ab0..c919a56ac 100644
--- a/lang/m2/comp/LLlex.h
+++ b/lang/m2/comp/LLlex.h
@@ -9,6 +9,8 @@
 
 /* $Header$ */
 
+#include "real.h"
+
 /* Structure to store a string constant
 */
 struct string {
@@ -25,7 +27,7 @@ struct token	{
 		struct idf *tk_idf;	/* IDENT	*/
 		struct string *tk_str;	/* STRING	*/
 		arith tk_int;		/* INTEGER	*/
-		char *tk_real;		/* REAL		*/
+		struct real *tk_real;	/* REAL		*/
 		arith *tk_set;		/* only used in parse tree node */
 		struct def *tk_def;	/* only used in parse tree node */
 		label tk_lab;		/* only used in parse tree node */
@@ -38,7 +40,8 @@ typedef struct token	t_token;
 #define TOK_STR	tk_data.tk_str->s_str
 #define TOK_SLE tk_data.tk_str->s_length
 #define TOK_INT	tk_data.tk_int
-#define TOK_REL tk_data.tk_real
+#define TOK_REAL tk_data.tk_real->r_real
+#define TOK_RVAL tk_data.tk_real->r_val
 
 extern t_token dot, aside;
 extern struct type *toktype;
diff --git a/lang/m2/comp/LLmessage.c b/lang/m2/comp/LLmessage.c
index add039c8f..c4b1aeb90 100644
--- a/lang/m2/comp/LLmessage.c
+++ b/lang/m2/comp/LLmessage.c
@@ -55,7 +55,9 @@ LLmessage(tk)
 			dotp->TOK_INT = 1;
 			break;
 		case REAL:
-			dotp->TOK_REL = Salloc("0.0", 4);
+			dotp->tk_data.tk_real = new_real();
+			dotp->TOK_REAL = Salloc("0.0", 4);
+			flt_str2flt(dotp->TOK_REAL, &dotp->TOK_RVAL);
 			break;
 		}
 	}
diff --git a/lang/m2/comp/Makefile b/lang/m2/comp/Makefile
index e712341eb..a3043f20a 100644
--- a/lang/m2/comp/Makefile
+++ b/lang/m2/comp/Makefile
@@ -20,20 +20,19 @@ MODLIB =	$(LIBDIR)/libinput.a \
 		$(LIBDIR)/libassert.a \
 		$(LIBDIR)/liballoc.a \
 		$(MALLOC) \
+		$(LIBDIR)/libflt.a \
 		$(LIBDIR)/libprint.a \
 		$(LIBDIR)/libstring.a \
 		$(LIBDIR)/libsystem.a
 EMCELIB =	$(LIBDIR)/libem_mesCE.a \
 		$(EMHOME)/lib/$(MACH)/ce.a \
 		$(EMHOME)/lib/$(MACH)/$(BACK).a \
-		$(LIBDIR)/libflt.a \
 		$(LIBDIR)/libobject.a \
 		$(EMHOME)/lib/em_data.a
 EMOCELIB =	$(LIBDIR)/libem_mesO.a \
 		$(LIBDIR)/libCEopt.a \
 		$(EMHOME)/lib/$(MACH)/ce.a \
 		$(EMHOME)/lib/$(MACH)/$(BACK).a \
-		$(LIBDIR)/libflt.a \
 		$(LIBDIR)/libobject.a \
 		$(EMHOME)/lib/em_data.a
 
@@ -49,8 +48,8 @@ PROFILE =
 COPTIONS =
 INCLUDES =	-I$(MHDIR) -I$(EMHOME)/h -I$(PKGDIR)
 OPTIM =		-O
-CFLAGS =	$(PROFILE) $(INCLUDES) $(COPTIONS) $(OPTIM) -DSTATIC=
-LINTFLAGS =	-DSTATIC= -DNORCSID
+CFLAGS =	$(PROFILE) $(INCLUDES) $(COPTIONS) $(OPTIM)
+LINTFLAGS =
 LDFLAGS =	-i $(PROFILE)
 
 LSRC =	tokenfile.c program.c declar.c expression.c statement.c
@@ -77,14 +76,14 @@ OBJ =	$(COBJ) $(LOBJ) Lpars.o $(EXTRA_O)
 GENH =	errout.h \
 	idfsize.h numsize.h strsize.h target_sizes.h bigparam.h bigresult.h \
 	inputtype.h density.h squeeze.h nocross.h nostrict.h \
-	def.h debugcst.h type.h Lpars.h node.h desig.h strict3rd.h
+	def.h debugcst.h type.h Lpars.h node.h desig.h strict3rd.h real.h
 HFILES =LLlex.h \
 	chk_expr.h class.h const.h debug.h f_info.h idf.h \
 	input.h main.h misc.h scope.h standards.h tokenname.h \
 	walk.h warning.h SYSTEM.h $(GENH)
 #
 GENFILES =	$(GENGFILES) $(GENC) $(GENH)
-NEXTFILES =	def.H type.H node.H desig.H scope.C tmpvar.C casestat.C
+NEXTFILES =	def.H type.H node.H desig.H real.H scope.C tmpvar.C casestat.C
 
 #EXCLEXCLEXCLEXCL
 
@@ -159,6 +158,7 @@ symbol2str.c:	tokenname.c make.tokcase
 
 def.h:		make.allocd
 type.h:		make.allocd
+real.h:		make.allocd
 node.h:		make.allocd
 desig.h:	make.allocd
 scope.c:	make.allocd
@@ -188,6 +188,7 @@ Xlint:
 		$(LIBDIR)/llib-linput.ln \
 		$(LIBDIR)/llib-lassert.ln \
 		$(LIBDIR)/llib-lalloc.ln \
+		$(LIBDIR)/llib-lflt.ln \
 		$(LIBDIR)/llib-lprint.ln \
 		$(LIBDIR)/llib-lstring.ln \
 		$(LIBDIR)/llib-lsystem.ln
@@ -221,6 +222,7 @@ LLlex.o: input.h
 LLlex.o: inputtype.h
 LLlex.o: nocross.h
 LLlex.o: numsize.h
+LLlex.o: real.h
 LLlex.o: strsize.h
 LLlex.o: target_sizes.h
 LLlex.o: type.h
@@ -228,6 +230,7 @@ LLlex.o: warning.h
 LLmessage.o: LLlex.h
 LLmessage.o: Lpars.h
 LLmessage.o: idf.h
+LLmessage.o: real.h
 error.o: LLlex.h
 error.o: debug.h
 error.o: debugcst.h
@@ -238,6 +241,7 @@ error.o: inputtype.h
 error.o: main.h
 error.o: node.h
 error.o: nostrict.h
+error.o: real.h
 error.o: strict3rd.h
 error.o: warning.h
 main.o: LLlex.h
@@ -253,6 +257,7 @@ main.o: input.h
 main.o: inputtype.h
 main.o: nocross.h
 main.o: node.h
+main.o: real.h
 main.o: scope.h
 main.o: standards.h
 main.o: strict3rd.h
@@ -278,6 +283,7 @@ type.o: idf.h
 type.o: nocross.h
 type.o: node.h
 type.o: nostrict.h
+type.o: real.h
 type.o: scope.h
 type.o: squeeze.h
 type.o: target_sizes.h
@@ -294,6 +300,7 @@ def.o: idf.h
 def.o: main.h
 def.o: nocross.h
 def.o: node.h
+def.o: real.h
 def.o: scope.h
 def.o: target_sizes.h
 def.o: type.h
@@ -303,6 +310,7 @@ misc.o: f_info.h
 misc.o: idf.h
 misc.o: misc.h
 misc.o: node.h
+misc.o: real.h
 enter.o: LLlex.h
 enter.o: bigparam.h
 enter.o: debug.h
@@ -314,6 +322,7 @@ enter.o: main.h
 enter.o: misc.h
 enter.o: nocross.h
 enter.o: node.h
+enter.o: real.h
 enter.o: scope.h
 enter.o: target_sizes.h
 enter.o: type.h
@@ -331,6 +340,7 @@ defmodule.o: main.h
 defmodule.o: misc.h
 defmodule.o: nocross.h
 defmodule.o: node.h
+defmodule.o: real.h
 defmodule.o: scope.h
 defmodule.o: target_sizes.h
 defmodule.o: type.h
@@ -343,6 +353,7 @@ typequiv.o: idf.h
 typequiv.o: main.h
 typequiv.o: nocross.h
 typequiv.o: node.h
+typequiv.o: real.h
 typequiv.o: strict3rd.h
 typequiv.o: target_sizes.h
 typequiv.o: type.h
@@ -355,16 +366,19 @@ node.o: def.h
 node.o: main.h
 node.o: nocross.h
 node.o: node.h
+node.o: real.h
 node.o: target_sizes.h
 node.o: type.h
 cstoper.o: LLlex.h
 cstoper.o: Lpars.h
 cstoper.o: bigparam.h
+cstoper.o: const.h
 cstoper.o: debug.h
 cstoper.o: debugcst.h
 cstoper.o: idf.h
 cstoper.o: nocross.h
 cstoper.o: node.h
+cstoper.o: real.h
 cstoper.o: standards.h
 cstoper.o: target_sizes.h
 cstoper.o: type.h
@@ -383,6 +397,7 @@ chk_expr.o: misc.h
 chk_expr.o: nocross.h
 chk_expr.o: node.h
 chk_expr.o: nostrict.h
+chk_expr.o: real.h
 chk_expr.o: scope.h
 chk_expr.o: standards.h
 chk_expr.o: strict3rd.h
@@ -415,6 +430,7 @@ walk.o: main.h
 walk.o: misc.h
 walk.o: nocross.h
 walk.o: node.h
+walk.o: real.h
 walk.o: scope.h
 walk.o: squeeze.h
 walk.o: strict3rd.h
@@ -430,6 +446,7 @@ desig.o: def.h
 desig.o: desig.h
 desig.o: nocross.h
 desig.o: node.h
+desig.o: real.h
 desig.o: scope.h
 desig.o: squeeze.h
 desig.o: target_sizes.h
@@ -446,6 +463,7 @@ code.o: def.h
 code.o: desig.h
 code.o: nocross.h
 code.o: node.h
+code.o: real.h
 code.o: scope.h
 code.o: squeeze.h
 code.o: standards.h
@@ -461,6 +479,7 @@ lookup.o: idf.h
 lookup.o: misc.h
 lookup.o: nocross.h
 lookup.o: node.h
+lookup.o: real.h
 lookup.o: scope.h
 lookup.o: target_sizes.h
 lookup.o: type.h
@@ -476,6 +495,7 @@ program.o: idf.h
 program.o: main.h
 program.o: nocross.h
 program.o: node.h
+program.o: real.h
 program.o: scope.h
 program.o: strict3rd.h
 program.o: target_sizes.h
@@ -494,6 +514,7 @@ declar.o: misc.h
 declar.o: nocross.h
 declar.o: node.h
 declar.o: nostrict.h
+declar.o: real.h
 declar.o: scope.h
 declar.o: strict3rd.h
 declar.o: target_sizes.h
@@ -510,6 +531,7 @@ expression.o: def.h
 expression.o: idf.h
 expression.o: nocross.h
 expression.o: node.h
+expression.o: real.h
 expression.o: target_sizes.h
 expression.o: type.h
 expression.o: warning.h
@@ -520,6 +542,7 @@ statement.o: def.h
 statement.o: idf.h
 statement.o: nocross.h
 statement.o: node.h
+statement.o: real.h
 statement.o: scope.h
 statement.o: target_sizes.h
 statement.o: type.h
@@ -537,6 +560,7 @@ casestat.o: density.h
 casestat.o: desig.h
 casestat.o: nocross.h
 casestat.o: node.h
+casestat.o: real.h
 casestat.o: squeeze.h
 casestat.o: target_sizes.h
 casestat.o: type.h
@@ -548,6 +572,7 @@ tmpvar.o: debugcst.h
 tmpvar.o: def.h
 tmpvar.o: main.h
 tmpvar.o: nocross.h
+tmpvar.o: real.h
 tmpvar.o: scope.h
 tmpvar.o: target_sizes.h
 tmpvar.o: type.h
@@ -559,6 +584,7 @@ scope.o: def.h
 scope.o: idf.h
 scope.o: nocross.h
 scope.o: node.h
+scope.o: real.h
 scope.o: scope.h
 scope.o: target_sizes.h
 scope.o: type.h
diff --git a/lang/m2/comp/chk_expr.c b/lang/m2/comp/chk_expr.c
index bd09e46f0..02c831485 100644
--- a/lang/m2/comp/chk_expr.c
+++ b/lang/m2/comp/chk_expr.c
@@ -37,6 +37,7 @@
 
 extern char *symbol2str();
 extern char *sprint();
+extern arith flt2arith();
 
 STATIC int
 df_error(nd, mess, edf)
@@ -78,14 +79,53 @@ MkCoercion(pnd, tp)
 	register t_type	*nd_tp = nd->nd_type;
 	extern int	pass_1;
 	char		*wmess = 0;
+	arith		op;
 
 	if (nd_tp == tp || nd_tp->tp_fund == T_STRING /* Why ??? */) return;
 	nd_tp = BaseType(nd_tp);
-	if (nd->nd_class == Value &&
-	    nd_tp->tp_fund != T_REAL &&
-	    tp->tp_fund != T_REAL) {
-		/* Constant expression not involving REALs */
+	if (nd->nd_class == Value) {
+		if (nd_tp->tp_fund == T_REAL) {
+			switch(tp->tp_fund) {
+			case T_REAL:
+				nd->nd_type = tp;
+				return;
+			case T_CARDINAL:
+				op = flt_flt2arith(&nd->nd_RVAL, 1);
+				break;
+			case T_INTEGER:
+				op = flt_flt2arith(&nd->nd_RVAL, 0);
+				break;
+			default:
+				crash("MkCoercion");
+			}
+			if (flt_status == FLT_OVFL) {
+				wmess = "conversion";
+			}
+			if (!wmess || pass_1) {
+				if (nd->nd_REAL) free(nd->nd_REAL);
+				free_real(nd->nd_token.tk_data.tk_real);
+				nd->nd_INT = op;
+				nd->nd_symb = INTEGER;
+			}
+		}
 		switch(tp->tp_fund) {
+		case T_REAL: {
+			struct real *p = new_real();
+			switch(BaseType(nd_tp)->tp_fund) {
+			case T_CARDINAL:
+			case T_INTORCARD:
+				flt_arith2flt(nd->nd_INT, &p->r_val, 1);
+				break;
+			case T_INTEGER:
+				flt_arith2flt(nd->nd_INT, &p->r_val, 0);
+				break;
+			default:
+				crash("MkCoercion");
+			}
+			nd->nd_token.tk_data.tk_real = p;
+			nd->nd_symb = REAL;
+			}
+			break;
 		case T_SUBRANGE:
 		case T_ENUMERATION:
 		case T_CHAR:
@@ -330,6 +370,16 @@ ChkExLinkOrName(expp)
 			expp->nd_class = Def;
 		}
 		else	expp->nd_class = Value;
+		if (df->df_type->tp_fund == T_REAL) {
+			struct real *p = expp->nd_token.tk_data.tk_real;
+
+			expp->nd_token.tk_data.tk_real = new_real();
+			*(expp->nd_token.tk_data.tk_real) = *p;
+			if (p->r_real) {
+				p->r_real = Salloc(p->r_real,
+					   (unsigned)(strlen(p->r_real)+1));
+			}
+		}
 	}
 
 	if (!(df->df_kind & D_VALUE)) {
@@ -912,12 +962,14 @@ ChkBinOper(expp)
 			cstset(expp);
 		}
 	}
-	else if ( tpl->tp_fund != T_REAL &&
-		  expp->nd_left->nd_class == Value &&
+	else if ( expp->nd_left->nd_class == Value &&
 		  expp->nd_right->nd_class == Value) {
 		if (expp->nd_left->nd_type->tp_fund == T_INTEGER) {
 			cstibin(expp);
 		}
+		else if (tpl->tp_fund == T_REAL) {
+			cstfbin(expp);
+		}
 		else	cstubin(expp);
 	}
 
@@ -967,8 +1019,11 @@ ChkUnOper(expp)
 		else if (tpr->tp_fund == T_REAL) {
 			if (right->nd_class == Value) {
 				*expp = *right;
-				if (*(expp->nd_REL) == '-') (expp->nd_REL)++;
-				else (expp->nd_REL)--;
+				flt_umin(&(expp->nd_RVAL));
+				if (expp->nd_REAL) {
+					free(expp->nd_REAL);
+					expp->nd_REAL = 0;
+				}
 				FreeNode(right);
 			}
 			return 1;
@@ -976,6 +1031,7 @@ ChkUnOper(expp)
 		break;
 
 	case NOT:
+	case '~':
 		if (tpr == bool_type) {
 			if (right->nd_class == Value) {
 				cstunary(expp);
@@ -1026,6 +1082,10 @@ ChkStandard(expp)
 		MkCoercion(&(arg->nd_left), expp->nd_type);
 		switch(expp->nd_type->tp_fund) {
 		case T_REAL:
+			if (arg->nd_left->nd_class == Value) {
+				arg->nd_left->nd_RVAL.flt_sign = 0;
+				free_it = 1;
+			}
 			break;
 		case T_INTEGER:
 			if (arg->nd_left->nd_class == Value) {
diff --git a/lang/m2/comp/code.c b/lang/m2/comp/code.c
index 0a5af056e..f29a3f536 100644
--- a/lang/m2/comp/code.c
+++ b/lang/m2/comp/code.c
@@ -127,7 +127,13 @@ CodeExpr(nd, ds, true_label, false_label)
 		switch(nd->nd_symb) {
 		case REAL:
 			C_df_dlb(++data_label);
-			C_rom_fcon(nd->nd_REL, tp->tp_size);
+			if (! nd->nd_REAL) {
+				static char buf[FLT_STRLEN];
+
+				flt_flt2str(&nd->nd_RVAL, buf, FLT_STRLEN);
+				C_rom_fcon(buf, tp->tp_size);
+			}
+			else C_rom_fcon(nd->nd_REAL, tp->tp_size);
 			c_lae_dlb(data_label);
 			C_loi(tp->tp_size);
 			break;
diff --git a/lang/m2/comp/cstoper.c b/lang/m2/comp/cstoper.c
index def4c48dc..2cb9133ec 100644
--- a/lang/m2/comp/cstoper.c
+++ b/lang/m2/comp/cstoper.c
@@ -15,6 +15,7 @@
 #include	<em_arith.h>
 #include	<em_label.h>
 #include	<assert.h>
+#include	<alloc.h>
 
 #include	"idf.h"
 #include	"type.h"
@@ -25,6 +26,8 @@
 #include	"warning.h"
 #include	"const.h"
 
+extern char	*symbol2str();
+
 arith full_mask[MAXSIZE];/* full_mask[1] == 0xFF, full_mask[2] == 0xFFFF, .. */
 arith max_int[MAXSIZE];	/* max_int[1] == 0x7F, max_int[2] == 0x7FFF, .. */
 arith min_int[MAXSIZE];	/* min_int[1] == 0xFFFFFF80, min_int[2] = 0xFFFF8000,
@@ -266,6 +269,91 @@ cstibin(expp)
 	expp->nd_INT = o1;
 }
 
+cstfbin(expp)
+	register t_node *expp;
+{
+	/*	The binary operation in "expp" is performed on the constant
+		expressions below it, and the result restored in expp.
+		This version is for REAL expressions.
+	*/
+	register struct real *p = expp->nd_left->nd_token.tk_data.tk_real;
+	register flt_arith *o1 = &p->r_val;
+	register flt_arith *o2 = &expp->nd_right->nd_RVAL;
+	int compar = 0;
+	int cmpval = 0;
+
+	assert(expp->nd_class == Oper);
+	assert(expp->nd_left->nd_class == Value);
+	assert(expp->nd_right->nd_class == Value);
+
+	switch (expp->nd_symb)	{
+	case '*':
+		flt_mul(o1, o2, o1);
+		break;
+
+	case '/':
+		flt_div(o1, o2, o1);
+		break;
+
+	case '+':
+		flt_add(o1, o2, o1);
+		break;
+
+	case '-':
+		flt_sub(o1, o2, o1);
+		break;
+
+	case '<':
+	case '>':
+	case LESSEQUAL:
+	case GREATEREQUAL:
+	case '=':
+	case '#':
+		compar++;
+		cmpval = flt_cmp(o1, o2);
+		switch(expp->nd_symb) {
+		case '<':		cmpval = (cmpval < 0); break;
+		case '>':		cmpval = (cmpval > 0); break;
+		case LESSEQUAL:		cmpval = (cmpval <= 0); break;
+		case GREATEREQUAL:	cmpval = (cmpval >= 0); break;
+		case '=':		cmpval = (cmpval == 0); break;
+		case '#':		cmpval = (cmpval != 0); break;
+		}
+		if (expp->nd_right->nd_REAL) free(expp->nd_right->nd_REAL);
+		free_real(expp->nd_right->nd_token.tk_data.tk_real);
+		break;
+
+	default:
+		crash("(cstfbin)");
+	}
+
+	switch(flt_status) {
+	case FLT_OVFL:
+		node_warning(expp, "floating point overflow on %s", 
+				symbol2str(expp->nd_symb));
+		break;
+	case FLT_DIV0:
+		node_error(expp, "division by 0.0");
+		break;
+	}
+
+	if (p->r_real) {
+		free(p->r_real);
+		p->r_real = 0;
+	}
+	if (compar) {
+		free_real(p);
+	}
+	commonbin(expp);
+	if (compar) {
+		expp->nd_symb = INTEGER;
+		expp->nd_INT = cmpval;
+	}
+	else {
+		expp->nd_token.tk_data.tk_real = p;
+	}
+}
+
 cstubin(expp)
 	register t_node *expp;
 {
@@ -564,6 +652,7 @@ CutSize(expr)
 	register t_type *tp = BaseType(expr->nd_type);
 
 	assert(expr->nd_class == Value);
+	if (tp->tp_fund == T_REAL) return;
 	if (tp->tp_fund != T_INTEGER) {
 		expr->nd_INT &= full_mask[(int)(tp->tp_size)];
 	}
diff --git a/lang/m2/comp/debug.h b/lang/m2/comp/debug.h
index 40a8d48a1..51e325b23 100644
--- a/lang/m2/comp/debug.h
+++ b/lang/m2/comp/debug.h
@@ -13,6 +13,8 @@
 
 #ifdef DEBUG
 #define DO_DEBUG(x, y)	((x) && (y))
+#define STATIC
 #else
 #define DO_DEBUG(x, y)
+#define STATIC static
 #endif
diff --git a/lang/m2/comp/main.c b/lang/m2/comp/main.c
index 4db3b49cd..a94e9b1a3 100644
--- a/lang/m2/comp/main.c
+++ b/lang/m2/comp/main.c
@@ -136,7 +136,7 @@ LexScan()
 			break;
 		
 		case REAL:
-			print("%s\n", tkp->TOK_REL);
+			print("%s\n", tkp->TOK_REAL);
 			break;
 
 		case STRING:
diff --git a/lang/m2/comp/node.H b/lang/m2/comp/node.H
index c8fffc501..e05370eab 100644
--- a/lang/m2/comp/node.H
+++ b/lang/m2/comp/node.H
@@ -40,7 +40,8 @@ struct node {
 #define nd_STR		nd_token.TOK_STR
 #define nd_SLE		nd_token.TOK_SLE
 #define nd_INT		nd_token.TOK_INT
-#define nd_REL		nd_token.TOK_REL
+#define nd_REAL		nd_token.TOK_REAL
+#define nd_RVAL		nd_token.TOK_RVAL
 };
 
 typedef struct node	t_node;
diff --git a/lang/m2/comp/real.H b/lang/m2/comp/real.H
new file mode 100644
index 000000000..f75ca519b
--- /dev/null
+++ b/lang/m2/comp/real.H
@@ -0,0 +1,19 @@
+/*
+ * (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ * See the copyright notice in the ACK home directory, in the file "Copyright".
+ *
+ * Author: Ceriel J.H. Jacobs
+ */
+
+/* R E A L   C O N S T A N T   D E S C R I P T O R   D E F I N I T I O N */
+
+/* $Header$ */
+
+#include <flt_arith.h>
+
+struct real {
+	char		*r_real;
+	flt_arith	r_val;
+};
+
+/* ALLOCDEF "real" 20 */
diff --git a/lang/m2/comp/type.c b/lang/m2/comp/type.c
index 7510cb54d..76bee53aa 100644
--- a/lang/m2/comp/type.c
+++ b/lang/m2/comp/type.c
@@ -820,11 +820,11 @@ intorcard(left, right)
 	register t_type *left, *right;
 {
 	if (left == intorcard_type) {
-		if (right == int_type || right == card_type) {
-			return right;
-		}
+		t_type *tmp = left;
+		left = right;
+		right = tmp;
 	}
-	else if (right == intorcard_type) {
+	if (right == intorcard_type) {
 		if (left == int_type || left == card_type) {
 			return left;
 		}