newer version

lang/m2/comp/Makefile

@@ -17,7 +17,8 @@ LFLAGS = $(PROFILE)
 LOBJ =	tokenfile.o program.o declar.o expression.o statement.o
 COBJ =	LLlex.o LLmessage.o char.o error.o main.o \
 	symbol2str.o tokenname.o idf.o input.o type.o def.o \
-	scope.o misc.o enter.o defmodule.o typequiv.o node.o
+	scope.o misc.o enter.o defmodule.o typequiv.o node.o \
+	cstoper.o
 OBJ =	$(COBJ) $(LOBJ) Lpars.o
 GENFILES=	tokenfile.c \
 	program.c declar.c expression.c statement.c \
@@ -80,15 +81,16 @@ idf.o: idf.h
 input.o: f_info.h input.h
 type.o: LLlex.h Lpars.h def.h def_sizes.h idf.h node.h type.h
 def.o: LLlex.h Lpars.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 scope.h type.h
+scope.o: LLlex.h debug.h def.h idf.h main.h scope.h type.h
 misc.o: LLlex.h f_info.h idf.h misc.h
 enter.o: LLlex.h def.h idf.h node.h scope.h type.h
 defmodule.o: LLlex.h def.h f_info.h idf.h input.h scope.h
 typequiv.o: Lpars.h def.h type.h
-node.o: LLlex.h def.h node.h type.h
+node.o: LLlex.h debug.h def.h main.h node.h type.h
+cstoper.o: Lpars.h def_sizes.h idf.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 misc.h node.h scope.h type.h
-expression.o: LLlex.h Lpars.h def.h idf.h node.h scope.h
+expression.o: LLlex.h Lpars.h debug.h def.h idf.h main.h node.h scope.h
-statement.o: Lpars.h
+statement.o: LLlex.h Lpars.h node.h
 Lpars.o: Lpars.h

lang/m2/comp/const.h

@@ -0,0 +1,12 @@
+/* C O N S T A N T S   F O R   E X P R E S S I O N   H A N D L I N G */
+
+/* $Header$ */
+
+extern long
+	mach_long_sign;	/* sign bit of the machine long */
+extern int
+	mach_long_size;	/* size of long on this machine == sizeof(long) */
+extern arith
+	max_int,	/* maximum integer on target machine	*/
+	max_unsigned,	/* maximum unsigned on target machine	*/
+	max_longint;	/* maximum longint on target machine	*/

lang/m2/comp/cstoper.c

@@ -0,0 +1,238 @@
+/*	C O N S T A N T   E X P R E S S I O N   H A N D L I N G		*/
+
+static char *RcsId = "$Header$";
+
+#include	<em_arith.h>
+#include	<em_label.h>
+#include	<assert.h>
+#include	"def_sizes.h"
+#include	"idf.h"
+#include	"type.h"
+#include	"LLlex.h"
+#include	"node.h"
+#include	"Lpars.h"
+
+long mach_long_sign;	/* sign bit of the machine long */
+int mach_long_size;	/* size of long on this machine == sizeof(long) */
+long full_mask[MAXSIZE];/* full_mask[1] == 0XFF, full_mask[2] == 0XFFFF, .. */
+arith max_int;		/* maximum integer on target machine	*/
+arith max_unsigned;	/* maximum unsigned on target machine	*/
+arith max_longint;	/* maximum longint on target machine	*/
+
+#if 0
+
+cstbin(expp, oper, expr)
+	struct expr **expp, *expr;
+{
+	/*	The operation oper is performed on the constant
+		expressions *expp(ld) and expr(ct), and the result restored in
+		*expp.
+	*/
+	arith o1 = (*expp)->VL_VALUE;
+	arith o2 = expr->VL_VALUE;
+	int uns = (*expp)->ex_type->tp_unsigned;
+
+	ASSERT(is_ld_cst(*expp) && is_cp_cst(expr));
+	switch (oper)	{
+	case '*':
+		o1 *= o2;
+		break;
+	case '/':
+		if (o2 == 0)	{
+			expr_error(expr, "division by 0");
+			break;
+		}
+		if (uns)	{
+			/*	this is more of a problem than you might
+				think on C compilers which do not have
+				unsigned long.
+			*/
+			if (o2 & mach_long_sign)	{/* o2 > max_long */
+				o1 = ! (o1 >= 0 || o1 < o2);
+				/*	this is the unsigned test
+					o1 < o2 for o2 > max_long
+				*/
+			}
+			else	{		/* o2 <= max_long */
+				long half, bit, hdiv, hrem, rem;
+
+				half = (o1 >> 1) & ~mach_long_sign;
+				bit = o1 & 01;
+				/*	now o1 == 2 * half + bit
+					and half <= max_long
+					and bit <= max_long
+				*/
+				hdiv = half / o2;
+				hrem = half % o2;
+				rem = 2 * hrem + bit;
+				o1 = 2 * hdiv + (rem < 0 || rem >= o2);
+				/*	that is the unsigned compare
+					rem >= o2 for o2 <= max_long
+				*/
+			}
+		}
+		else
+			o1 /= o2;
+		break;
+	case '%':
+		if (o2 == 0)	{
+			expr_error(expr, "modulo by 0");
+			break;
+		}
+		if (uns)	{
+			if (o2 & mach_long_sign)	{/* o2 > max_long */
+				o1 = (o1 >= 0 || o1 < o2) ? o1 : o1 - o2;
+				/*	this is the unsigned test
+					o1 < o2 for o2 > max_long
+				*/
+			}
+			else	{		/* o2 <= max_long */
+				long half, bit, hrem, rem;
+
+				half = (o1 >> 1) & ~mach_long_sign;
+				bit = o1 & 01;
+				/*	now o1 == 2 * half + bit
+					and half <= max_long
+					and bit <= max_long
+				*/
+				hrem = half % o2;
+				rem = 2 * hrem + bit;
+				o1 = (rem < 0 || rem >= o2) ? rem - o2 : rem;
+			}
+		}
+		else
+			o1 %= o2;
+		break;
+	case '+':
+		o1 += o2;
+		break;
+	case '-':
+		o1 -= o2;
+		break;
+	case LEFT:
+		o1 <<= o2;
+		break;
+	case RIGHT:
+		if (o2 == 0)
+			break;
+		if (uns)	{
+			o1 >>= 1;
+			o1 & = ~mach_long_sign;
+			o1 >>= (o2-1);
+		}
+		else
+			o1 >>= o2;
+		break;
+	case '<':
+		if (uns)	{
+			o1 = (o1 & mach_long_sign ?
+				(o2 & mach_long_sign ? o1 < o2 : 0) :
+				(o2 & mach_long_sign ? 1 : o1 < o2)
+			);
+		}
+		else
+			o1 = o1 < o2;
+		break;
+	case '>':
+		if (uns)	{
+			o1 = (o1 & mach_long_sign ?
+				(o2 & mach_long_sign ? o1 > o2 : 1) :
+				(o2 & mach_long_sign ? 0 : o1 > o2)
+			);
+		}
+		else
+			o1 = o1 > o2;
+		break;
+	case LESSEQ:
+		if (uns)	{
+			o1 = (o1 & mach_long_sign ?
+				(o2 & mach_long_sign ? o1 <= o2 : 0) :
+				(o2 & mach_long_sign ? 1 : o1 <= o2)
+			);
+		}
+		else
+			o1 = o1 <= o2;
+		break;
+	case GREATEREQ:
+		if (uns)	{
+			o1 = (o1 & mach_long_sign ?
+				(o2 & mach_long_sign ? o1 >= o2 : 1) :
+				(o2 & mach_long_sign ? 0 : o1 >= o2)
+			);
+		}
+		else
+			o1 = o1 >= o2;
+		break;
+	case EQUAL:
+		o1 = o1 == o2;
+		break;
+	case NOTEQUAL:
+		o1 = o1 != o2;
+		break;
+	case '&':
+		o1 &= o2;
+		break;
+	case '|':
+		o1 |= o2;
+		break;
+	case '^':
+		o1 ^= o2;
+		break;
+	}
+	(*expp)->VL_VALUE = o1;
+	cut_size(*expp);
+	(*expp)->ex_flags |= expr->ex_flags;
+	(*expp)->ex_flags &= ~EX_PARENS;
+}
+
+cut_size(expr)
+	struct expr *expr;
+{
+	/*	The constant value of the expression expr is made to
+		conform to the size of the type of the expression.
+	*/
+	arith o1 = expr->VL_VALUE;
+	int uns = expr->ex_type->tp_unsigned;
+	int size = (int) expr->ex_type->tp_size;
+
+	ASSERT(expr->ex_class == Value);
+	if (uns) {
+		if (o1 & ~full_mask[size])
+			expr_warning(expr,
+				"overflow in unsigned constant expression");
+		o1 &= full_mask[size];
+	}
+	else {
+		int nbits = (int) (mach_long_size - size) * 8;
+		long remainder = o1 & ~full_mask[size];
+
+		if (remainder != 0 && remainder != ~full_mask[size])
+			expr_warning(expr, "overflow in constant expression");
+		o1 <<= nbits;		/* ??? */
+		o1 >>= nbits;
+	}
+	expr->VL_VALUE = o1;
+}
+
+# endif
+
+init_cst()
+{
+	int i = 0;
+	arith bt = (arith)0;
+
+	while (!(bt < 0))	{
+		bt = (bt << 8) + 0377, i++;
+		if (i == MAXSIZE)
+			fatal("array full_mask too small for this machine");
+		full_mask[i] = bt;
+	}
+	mach_long_size = i;
+	mach_long_sign = 1 << (mach_long_size * 8 - 1);
+	if (sizeof(long) < mach_long_size)
+		fatal("sizeof (long) insufficient on this machine");
+
+	max_int = full_mask[int_size] & ~(1 << (int_size * 8 - 1));
+	max_longint = full_mask[lint_size] & ~(1 << (lint_size * 8 - 1));
+	max_unsigned = full_mask[int_size];
+}

lang/m2/comp/def.c

@@ -34,7 +34,7 @@ define(id, scope, kind)
 	register struct def *df;
 	register struct scope *sc;
 
-	DO_DEBUG(debug(4,"Defining identifier %s in scope %d", id->id_text, scope->sc_scope));
+	DO_DEBUG(5, debug("Defining identifier \"%s\" in scope %d", id->id_text, scope->sc_scope));
 	df = lookup(id, scope->sc_scope);
 	if (	/* Already in this scope */
 		df
@@ -94,7 +94,7 @@ lookup(id, scope)
 
 	df1 = 0;
 	df = id->id_def;
-	DO_DEBUG(debug(4,"Looking for identifier %s in scope %d", id->id_text, scope));
+	DO_DEBUG(5, debug("Looking for identifier \"%s\" in scope %d", id->id_text, scope));
 	while (df) {
 		if (df->df_scope == scope) {
 			if (df->df_kind == D_IMPORT) {

lang/m2/comp/enter.c

@@ -5,6 +5,7 @@ static char *RcsId = "$Header$";
 #include	<alloc.h>
 #include	<em_arith.h>
 #include	<em_label.h>
+#include	<assert.h>
 #include	"idf.h"
 #include	"def.h"
 #include	"type.h"
@@ -17,6 +18,10 @@ Enter(name, kind, type, pnam)
 	char *name;
 	struct type *type;
 {
+	/*	Enter a definition for "name" with kind "kind" and type
+		"type" in the Current Scope. If it is a standard name, also
+		put its number in the definition structure.
+	*/
 	struct idf *id;
 	struct def *df;
 
@@ -35,6 +40,13 @@ EnterIdList(idlist, kind, flags, type, scope)
 	struct type *type;
 	struct scope *scope;
 {
+	/*	Put a list of identifiers in the symbol table.
+		They all have kind "kind", and type "type", and are put
+		in scope "scope". "flags" initializes the "df_flags" field
+		of the definition structure.
+		Also assign numbers to enumeration literals, and link
+		them together.
+	*/
 	register struct def *df;
 	struct def *first = 0, *last = 0;
 	int assval = 0;
@@ -45,15 +57,16 @@ EnterIdList(idlist, kind, flags, type, scope)
 		df->df_flags = flags;
 		if (kind == D_ENUM) {
 			if (!first) first = df;
-			df->df_value.df_enum.en_val = assval++;
+			df->enm_val = assval++;
-			if (last) last->df_value.df_enum.en_next = df;
+			if (last) last->enm_next = df;
 			last = df;
 		}
 		idlist = idlist->next;
 	}
 	if (last) {
-		/* Also meaning : enumeration */
+		/* Also meaning : kind == D_ENUM */
-		last->df_value.df_enum.en_next = 0;
+		assert(kind == D_ENUM);
+		last->enm_next = 0;
 		type->enm_enums = first;
 		type->enm_ncst = assval;
 	}

lang/m2/comp/error.c

@@ -46,10 +46,10 @@ extern char *symbol2str();
 
 #ifdef DEBUG
 /*VARARGS2*/
-debug(level, fmt, args)
+debug(fmt, args)
 	char *fmt;
 {
-	if (level <= options['D']) _error(VDEBUG, NULLNODE, fmt, &args);
+	_error(VDEBUG, NULLNODE, fmt, &args);
 }
 #endif DEBUG
 

lang/m2/comp/expression.g

@@ -6,19 +6,30 @@ static char *RcsId = "$Header$";
 #include	<alloc.h>
 #include	<em_arith.h>
 #include	<em_label.h>
+#include	"main.h"
 #include	"LLlex.h"
 #include	"idf.h"
 #include	"def.h"
 #include	"scope.h"
 #include	"node.h"
+#include	"const.h"
+#include	"type.h"
+#include	"debug.h"
 }
 
-number(struct node **p;):
+number(struct node **p;)
+{
+	struct type *tp;
+} :
 [
-	INTEGER
+	INTEGER		{ tp = dot.TOK_INT <= max_int ?
+				intorcard_type : card_type;
+			}
 |
-	REAL
+	REAL		{ tp = real_type; }
-]			{ *p = MkNode(Value, NULLNODE, NULLNODE, dot); }
+]			{ *p = MkNode(Value, NULLNODE, NULLNODE, &dot);
+			  (*p)->nd_type = tp;
+			}
 ;
 
 qualident(int types; struct def **pdf; char *str; struct node **p;)
@@ -27,15 +38,16 @@ qualident(int types; struct def **pdf; char *str; struct node **p;)
 	int  module;
 	register struct def *df;
 	struct def *lookfor();
+	register struct node **pnd;
+	struct node *nd;
 } :
 	IDENT		{ if (types) {
 				df = lookfor(dot.TOK_IDF, CurrentScope, 1);
 				*pdf = df;
 				if (df->df_kind == D_ERROR) types = 0;
 			  }
-			  if (p) {
+			  nd = MkNode(Value, NULLNODE, NULLNODE, &dot);
-			  	*p = MkNode(Value, NULLNODE, NULLNODE,&dot);
+			  pnd = &nd;
-			  }
 			}
 	[
 			{ if (types &&!(scope = has_selectors(df))) {
@@ -44,12 +56,11 @@ qualident(int types; struct def **pdf; char *str; struct node **p;)
 			  }
 			}
 		/* selector */
-		'.'	{ if (p) *p = MkNode(Link, *p, NULLNODE, &dot); }
+		'.'	{ *pnd = MkNode(Link,*pnd,NULLNODE,&dot);
-		IDENT
+			  pnd = &(*pnd)->nd_right;
-			{ if (p) {
-				p = &((*p)->nd_right);
-				*p = MkNode(Value, NULLNODE, NULLNODE,&dot);
 			}
+		IDENT
+			{ *pnd = MkNode(Value,NULLNODE,NULLNODE,&dot);
 			  if (types) {
 				module = (df->df_kind == D_MODULE);
 				df = lookup(dot.TOK_IDF, scope);
@@ -70,6 +81,8 @@ qualident(int types; struct def **pdf; char *str; struct node **p;)
 				error("identifier \"%s\" is not a %s",
 					df->df_idf->id_text, str);
 			  }
+			  if (!p) FreeNode(nd);
+			  else *p = nd;
 			}
 ;
 
@@ -98,22 +111,24 @@ ConstExpression(struct node **pnd;):
 	 * Changed rule in new Modula-2.
 	 * Check that the expression is a constant expression and evaluate!
 	 */
+		{ DO_DEBUG(3,
+		     ( debug("Constant expression:"),
+		       PrNode(*pnd)));
+		}
 ;
 
 expression(struct node **pnd;)
 {
-	struct node *nd;
 } :
-	SimpleExpression(&nd)
+	SimpleExpression(pnd)
 	[
 		/* relation */
 		[ '=' | '#' | UNEQUAL | '<' | LESSEQUAL | '>' |
 		  GREATEREQUAL | IN
 		]
-			{ nd = MkNode(Oper, nd, NULLNODE, &dot); }
+			{ *pnd = MkNode(Oper, *pnd, NULLNODE, &dot); }
-		SimpleExpression(&(nd->nd_right))
+		SimpleExpression(&((*pnd)->nd_right))
 	]?
-			{ *pnd = nd; }
 ;
 
 /* Inline in expression
@@ -124,15 +139,19 @@ relation:
 
 SimpleExpression(struct node **pnd;)
 {
-	register struct node *nd;
 } :
-	[ '+' | '-' ]?
+	[
-	term(pnd)	{ nd = *pnd; }
+		[ '+' | '-' ]
+			{ *pnd = MkNode(Uoper, NULLNODE, NULLNODE, &dot);
+			  pnd = &((*pnd)->nd_right);
+			}
+	]?
+	term(pnd)
 	[
 		/* AddOperator */
 		[ '+' | '-' | OR ]
-			{ *pnd = nd = MkNode(Oper, nd, NULLNODE, &dot); }
+			{ *pnd = MkNode(Oper, *pnd, NULLNODE, &dot); }
-		term(&(nd->nd_right))
+		term(&((*pnd)->nd_right))
 	]*
 ;
 
@@ -144,14 +163,13 @@ AddOperator:
 
 term(struct node **pnd;)
 {
-	register struct node *nd;
 }:
-	factor(pnd)	{ nd = *pnd; }
+	factor(pnd)
 	[
 		/* MulOperator */
 		[ '*' | '/' | DIV | MOD | AND | '&' ]
-			{ *pnd = nd = MkNode(Oper, nd, NULLNODE, &dot); }
+			{ *pnd = MkNode(Oper, *pnd, NULLNODE, &dot); }
-		factor(&(nd->nd_right))
+		factor(&((*pnd)->nd_right))
 	]*
 ;
 
@@ -164,23 +182,29 @@ MulOperator:
 factor(struct node **p;)
 {
 	struct def *df;
+	struct node *nd;
 } :
 	qualident(0, &df, (char *) 0, p)
 	[
 		designator_tail(p)?
 		[
-				{ *p = MkNode(Call, p, NULLNODE, &dot); } 
+			{ *p = MkNode(Call, *p, NULLNODE, &dot); }
 			ActualParameters(&((*p)->nd_right))
 		]?
-	|			{ *p = MkNode(Call, p, NULLNODE, &dot); }
+	|
-		bare_set(&((*p)->nd_right))
+		bare_set(&nd)
+			{ nd->nd_left = *p;
+			  *p = nd;
+			}
 	]
 |
 	bare_set(p)
 | %default
 	number(p)
 |
-	STRING		{ *p = MkNode(Value, NULLNODE, NULLNODE, &dot); }
+	STRING		{ *p = MkNode(Value, NULLNODE, NULLNODE, &dot);
+			  (*p)->nd_type = string_type;
+			}
 |
 	'(' expression(p) ')'
 |
@@ -190,20 +214,17 @@ factor(struct node **p;)
 
 bare_set(struct node **pnd;)
 {
-	struct node **nd;
+	register struct node *nd;
 } :
 	'{'		{
 			  dot.tk_symb = SET;
-			  *pnd = MkNode(Link, NULLNODE, NULLNODE, &dot);
+			  *pnd = nd = MkNode(Link, NULLNODE, NULLNODE, &dot);
-			  nd = &((*pnd)->nd_left);
+			  nd->nd_type = bitset_type;
 			}
 	[
 		element(nd)
-		[
+		[	{ nd = nd->nd_right; }
-			','	{ *nd = MkNode(Link, *nd, NULLNODE, &dot);
+			',' element(nd)
-				  nd = &((*nd)->nd_right);
-				}
-			element(nd)
 		]*
 	]?
 	'}'
@@ -213,12 +234,19 @@ ActualParameters(struct node **pnd;):
 	'(' ExpList(pnd)? ')'
 ;
 
-element(struct node **pnd;):
+element(struct node *nd;)
-	expression(pnd)
+{
+	struct node *nd1;
+} :
+	expression(&nd1)
 	[
-		UPTO		{ *pnd = MkNode(Link, *pnd, NULLNODE, &dot);}
+		UPTO
-		expression(&((*pnd)->nd_right))
+			{ nd1 = MkNode(Link, nd1, NULLNODE, &dot);}
+		expression(&(nd1->nd_right))
 	]?
+			{ nd->nd_right = MkNode(Link, nd1, NULLNODE, &dot);
+			  nd->nd_right->nd_symb = ',';
+			}
 ;
 
 designator(struct node **pnd;)

lang/m2/comp/main.c

@@ -47,7 +47,7 @@ main(argc, argv)
 #ifdef DEBUG
 	print("Mod2 compiler -- Debug version\n");
 #endif DEBUG
-	DO_DEBUG(debug(1,"Debugging level: %d", options['D']));
+	DO_DEBUG(1, debug("Debugging level: %d", options['D']));
 	return !Compile(Nargv[1]);
 }
 
@@ -56,7 +56,7 @@ Compile(src)
 {
 	extern struct tokenname tkidf[];
 
-	DO_DEBUG(debug(1,"Filename : %s", src));
+	DO_DEBUG(1, debug("Filename : %s", src));
 	if (! InsertFile(src, (char **) 0, &src)) {
 		fprint(STDERR,"%s: cannot open %s\n", ProgName, src);
 		return 0;
@@ -65,15 +65,13 @@ Compile(src)
 	FileName = src;
 	init_DEFPATH();
 	init_idf();
+	init_cst();
 	reserve(tkidf);
 	init_scope();
 	init_types();
 	add_standards();
 #ifdef DEBUG
-	if (options['L'])
+	if (options['L']) LexScan();
-		LexScan();
-	else if (options['T'])
-		TimeScan();
 	else {
 #endif DEBUG
 		(void) open_scope(CLOSEDSCOPE, 0);
@@ -92,7 +90,7 @@ LexScan()
 {
 	register int symb;
 
-	while ((symb = LLlex()) != EOI) {
+	while ((symb = LLlex()) > 0) {
 		print(">>> %s ", symbol2str(symb));
 		switch(symb) {
 
@@ -113,14 +111,10 @@ LexScan()
 			break;
 
 		default:
-			putchar('\n');
+			print("\n");
 		}
 	}
 }
-
-TimeScan() {
-	while (LLlex() != -1) /* nothing */;
-}
 #endif
 
 Option(str)
@@ -165,11 +159,7 @@ add_standards()
 		     D_TYPE,
 		     construct_type(PROCEDURE, NULLTYPE),
 		     0);
-	tp = construct_type(SUBRANGE, int_type);
+	df = Enter("BITSET", D_TYPE, bitset_type, 0);
-	tp->sub_lb = 0;
-	tp->sub_ub = wrd_size * 8 - 1;
-	df = Enter("BITSET", D_TYPE, construct_type(SET, tp), 0);
-	df->df_type->tp_size = wrd_size;
 	df = Enter("FALSE", D_ENUM, bool_type, 0);
 	df->df_value.df_enum.en_val = 0;
 	df->df_value.df_enum.en_next = Enter("TRUE", D_ENUM, bool_type, 0);

lang/m2/comp/node.c

@@ -5,10 +5,13 @@ static char *RcsId = "$Header$";
 #include	<em_label.h>
 #include	<em_arith.h>
 #include	<alloc.h>
+#include	<system.h>
+#include	"main.h"
 #include	"def.h"
 #include	"type.h"
 #include	"LLlex.h"
 #include	"node.h"
+#include	"debug.h"
 
 struct node *h_node;		/* header of free list */
 
@@ -26,6 +29,7 @@ MkNode(class, left, right, token)
 	nd->nd_token = *token;
 	nd->nd_class = class;
 	nd->nd_type = NULLTYPE;
+	DO_DEBUG(4,(debug("Create node:"), PrNode(nd)));
 	return nd;
 }
 
@@ -39,3 +43,28 @@ FreeNode(nd)
 	if (nd->nd_right) FreeNode(nd->nd_right);
 	free_node(nd);
 }
+
+#ifdef DEBUG
+
+extern char *symbol2str();
+
+static
+printnode(nd)
+	register struct node *nd;
+{
+	fprint(STDERR, "(");
+	if (nd) {
+		printnode(nd->nd_left);
+		fprint(STDERR, " %s ", symbol2str(nd->nd_symb));
+		printnode(nd->nd_right);
+	}
+	fprint(STDERR, ")");
+}
+
+PrNode(nd)
+	struct node *nd;
+{
+	printnode(nd);
+	fprint(STDERR, "\n");
+}
+#endif DEBUG

lang/m2/comp/program.g

@@ -114,7 +114,7 @@ DefinitionModule
 			  if (!SYSTEMModule) open_scope(CLOSEDSCOPE, 0);
 			  df->mod_scope = CurrentScope->sc_scope;
 			  DefinitionModule = 1;
-			  DO_DEBUG(debug(1, "Definition module \"%s\"", id->id_text));
+			  DO_DEBUG(1, debug("Definition module \"%s\"", id->id_text));
 			}
 	';'
 	import(0)* 

lang/m2/comp/scope.C

@@ -11,6 +11,7 @@ static char *RcsId = "$Header$";
 #include	"scope.h"
 #include	"type.h"
 #include	"def.h"
+#include	"main.h"
 #include	"debug.h"
 
 static int maxscope;		/* maximum assigned scope number */
@@ -35,7 +36,7 @@ open_scope(scopetype, scope)
 	sc->sc_scope = scope == 0 ? ++maxscope : scope;
 	sc->sc_forw = 0; sc->sc_def = 0;
 	assert(scopetype == OPENSCOPE || scopetype == CLOSEDSCOPE);
-	DO_DEBUG(debug(1, "Opening a %s scope",
+	DO_DEBUG(1, debug("Opening a %s scope",
 			scopetype == OPENSCOPE ? "open" : "closed"));
 	sc1 = CurrentScope;
 	if (scopetype == CLOSEDSCOPE) {
@@ -55,7 +56,7 @@ close_scope()
 	register struct scope *sc = CurrentScope;
 
 	assert(sc != 0);
-	DO_DEBUG(debug(1, "Closing a scope"));
+	DO_DEBUG(1, debug("Closing a scope"));
 	if (sc->sc_forw) rem_forwards(sc->sc_forw);
 	if (sc->next && (sc->next->sc_scope == 0)) {
 		struct scope *sc1 = sc;

lang/m2/comp/tokenname.c

@@ -80,6 +80,7 @@ struct tokenname tkinternal[] = {	/* internal keywords	*/
 	{ENUMERATION, ""},
 	{ERRONEOUS, ""},
 	{PROCVAR, ""},
+	{INTORCARD, ""},
 	{0, "0"}
 };
 

lang/m2/comp/type.H

@@ -77,7 +77,10 @@ extern struct type
 	*longreal_type,
 	*word_type,
 	*address_type,
-	*error_type;
+	*intorcard_type,
+	*string_type,
+	*bitset_type,
+	*error_type;		/* All from type.c */
 
 extern int
 	wrd_align,
@@ -86,7 +89,7 @@ extern int
 	real_align,
 	lreal_align,
 	ptr_align,
-	record_align;
+	record_align;		/* All from type.c */
 
 extern arith
 	wrd_size,
@@ -94,14 +97,14 @@ extern arith
 	lint_size,
 	real_size,
 	lreal_size,
-	ptr_size;
+	ptr_size;		/* All from type.c */
 
 extern arith
-	align();
+	align();		/* type.c */
 
 struct type
 	*create_type(),
 	*construct_type(),
-	*standard_type();
+	*standard_type();	/* All from type.c */
 
 #define NULLTYPE ((struct type *) 0)

lang/m2/comp/type.c

@@ -44,6 +44,9 @@ struct type
 	*longreal_type,
 	*word_type,
 	*address_type,
+	*intorcard_type,
+	*string_type,
+	*bitset_type,
 	*error_type;
 
 struct paramlist *h_paramlist;
@@ -123,6 +126,8 @@ standard_type(fund, align, size)
 
 init_types()
 {
+	register struct type *tp;
+
 	char_type = standard_type(CHAR, 1, (arith) 1);
 	bool_type = standard_type(BOOLEAN, 1, (arith) 1);
 	int_type = standard_type(INTEGER, int_align, int_size);
@@ -131,9 +136,15 @@ init_types()
 	real_type = standard_type(REAL, real_align, real_size);
 	longreal_type = standard_type(LONGREAL, lreal_align, lreal_size);
 	word_type = standard_type(WORD, wrd_align, wrd_size);
+	intorcard_type = standard_type(INTORCARD, int_align, int_size);
+	string_type = standard_type(STRING, 1, (arith) -1);
 	address_type = construct_type(POINTER, word_type);
+	tp = construct_type(SUBRANGE, int_type);
+	tp->sub_lb = 0;
+	tp->sub_ub = wrd_size * 8 - 1;
+	bitset_type = construct_type(SET, tp);
+	bitset_type->tp_size = wrd_size;
 	error_type = standard_type(ERRONEOUS, 1, (arith) 1);
-
 }
 
 int

lang/m2/comp/typequiv.c

@@ -52,3 +52,32 @@ TstProcEquiv(tp1, tp2)
 	if (p1 != p2) return 0;
 	return 1;
 }
+
+int
+TstCompat(tp1, tp2)
+	register struct type *tp1, *tp2;
+{
+	/*	test if two types are compatible. See section 6.3 of the
+		Modula-2 Report for a definition of "compatible".
+	*/
+	if (TstTypeEquiv(tp1, tp2)) return 1;
+	if (tp2->tp_fund == SUBRANGE) tp1 = tp1->next;
+	if (tp2->tp_fund == SUBRANGE) tp1 = tp1->next;
+	return	tp1 == tp2
+	    ||
+		(  tp1 == address_type
+		&& 
+	          (  tp2 == card_type
+		  || tp2 == intorcard_type
+		  || tp2->tp_fund == POINTER
+		  )
+		)
+	    ||
+		(  tp2 == address_type
+		&& 
+	          (  tp1 == card_type
+		  || tp1 == intorcard_type
+		  || tp1->tp_fund == POINTER
+		  )
+		);
+}