Added .globl, fix in Xfit call

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

@@ -0,0 +1,580 @@
+/*
+ * (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
+ */
+
+/* L E X I C A L   A N A L Y S E R   F O R   M O D U L A - 2 */
+
+/* $Header$ */
+
+#include	"debug.h"
+#include	"idfsize.h"
+#include	"numsize.h"
+#include	"strsize.h"
+
+#include	<alloc.h>
+#include	<em_arith.h>
+#include	<em_label.h>
+#include	<assert.h>
+
+#include	"LLlex.h"
+#include	"input.h"
+#include	"f_info.h"
+#include	"Lpars.h"
+#include	"class.h"
+#include	"idf.h"
+#include	"def.h"
+#include	"type.h"
+#include	"const.h"
+#include	"warning.h"
+
+long str2long();
+
+struct token	dot,
+		aside;
+struct type	*toktype;
+int		idfsize = IDFSIZE;
+int		ForeignFlag;
+#ifdef DEBUG
+extern int	cntlines;
+#endif
+
+static int	eofseen;
+extern char	options[];
+
+STATIC
+SkipComment()
+{
+	/*	Skip Modula-2 comments (* ... *).
+		Note that comments may be nested (par. 3.5).
+	*/
+	register int ch;
+	register int CommentLevel = 0;
+
+	LoadChar(ch);
+	if (ch == '$') {
+		LoadChar(ch);
+		switch(ch) {
+		case 'F':
+			/* Foreign; This definition module has an
+			   implementation in another language.
+			   In this case, don't generate prefixes in front
+			   of the names. Also, don't generate call to
+			   initialization routine.
+			*/
+			ForeignFlag = D_FOREIGN;
+			break;
+		case 'R':
+			/* Range checks, on or off */
+			LoadChar(ch);
+			if (ch == '-') {
+				options['R'] = 1;
+				break;
+			}
+			if (ch == '+') {
+				options['R'] = 0;
+				break;
+			}
+			/* fall through */
+		default:
+			PushBack();
+			break;
+		}
+	}
+	for (;;) {
+		if (class(ch) == STNL) {
+			LineNumber++;
+#ifdef DEBUG
+			cntlines++;
+#endif
+		}
+		else if (ch == '(') {
+			LoadChar(ch);
+			if (ch == '*') CommentLevel++;
+			else continue;
+		}
+		else if (ch == '*') {
+			LoadChar(ch);
+			if (ch == ')') {
+				CommentLevel--;
+				if (CommentLevel < 0) break;
+			}
+			else continue;
+		}
+		else if (ch == EOI) {
+			lexerror("unterminated comment");
+			break;
+		}
+		LoadChar(ch);
+	}
+}
+
+STATIC struct string *
+GetString(upto)
+{
+	/*	Read a Modula-2 string, delimited by the character "upto".
+	*/
+	register int ch;
+	register struct string *str = (struct string *)
+			Malloc((unsigned) sizeof(struct string));
+	register char *p;
+	register int len;
+	
+	len = ISTRSIZE;
+	str->s_str = p = Malloc((unsigned int) ISTRSIZE);
+	while (LoadChar(ch), ch != upto)	{
+		if (class(ch) == STNL)	{
+			lexerror("newline in string");
+			LineNumber++;
+#ifdef DEBUG
+			cntlines++;
+#endif
+			break;
+		}
+		if (ch == EOI)	{
+			lexerror("end-of-file in string");
+			break;
+		}
+		*p++ = ch;
+		if (p - str->s_str == len)	{
+			str->s_str = Realloc(str->s_str,
+				(unsigned int) len + RSTRSIZE);
+			p = str->s_str + len;
+			len += RSTRSIZE;
+		}
+	}
+	str->s_length = p - str->s_str;
+	while (p - str->s_str < len) *p++ = '\0';
+	if (str->s_length == 0) str->s_length = 1;
+	/* ??? string length at least 1 ??? */
+	return str;
+}
+
+static char *s_error = "illegal line directive";
+
+STATIC int
+getch()
+{
+	register int ch;
+
+	for (;;) {
+		LoadChar(ch);
+		if ((ch & 0200) && ch != EOI) {
+			error("non-ascii '\\%03o' read", ch & 0377);
+			continue;
+		}
+		break;
+	}
+	if (ch == EOI) {
+		eofseen = 1;
+		return '\n';
+	}
+	return ch;
+}
+
+CheckForLineDirective()
+{
+	register int ch = getch();
+	register int	i = 0;
+	char		buf[IDFSIZE + 2];
+	register char	*c = buf;
+
+
+	if (ch != '#') {
+		PushBack();
+		return;
+	}
+	do {	/*
+		 * Skip to next digit
+		 * Do not skip newlines
+		 */
+		ch = getch();
+		if (class(ch) == STNL) {
+			LineNumber++;
+			error(s_error);
+			return;
+		}
+	} while (class(ch) != STNUM);
+	while (class(ch) == STNUM)  {
+		i = i*10 + (ch - '0');
+		ch = getch();
+	}
+	while (ch != '"' && class(ch) != STNL) ch = getch();
+	if (ch == '"') {
+		c = buf;
+		do {
+			*c++ = ch = getch();
+			if (class(ch) == STNL) {
+				LineNumber++;
+				error(s_error);
+				return;
+			}
+		} while (ch != '"');
+		*--c = '\0';
+		do {
+			ch = getch();
+		} while (class(ch) != STNL);
+		/*
+		 * Remember the file name
+		 */
+		if (!eofseen && strcmp(FileName,buf)) {
+			FileName = Salloc(buf,(unsigned) strlen(buf) + 1);
+		}
+	}
+	if (eofseen) {
+		error(s_error);
+		return;
+	}
+	LineNumber = i;
+}
+
+int
+LLlex()
+{
+	/*	LLlex() is the Lexical Analyzer.
+		The putting aside of tokens is taken into account.
+	*/
+	register struct token *tk = &dot;
+	char buf[(IDFSIZE > NUMSIZE ? IDFSIZE : NUMSIZE) + 2];
+	register int ch, nch;
+
+	toktype = error_type;
+
+	if (ASIDE)	{	/* a token is put aside		*/
+		*tk = aside;
+		ASIDE = 0;
+		return tk->tk_symb;
+	}
+
+again1:
+	if (eofseen) {
+		eofseen = 0;
+		ch = EOI;
+	}
+	else {
+again:
+		LoadChar(ch);
+		if ((ch & 0200) && ch != EOI) {
+			error("non-ascii '\\%03o' read", ch & 0377);
+			goto again;
+		}
+	}
+
+	tk->tk_lineno = LineNumber;
+
+	switch (class(ch))	{
+
+	case STNL:
+		LineNumber++;
+#ifdef DEBUG
+		cntlines++;
+#endif
+		CheckForLineDirective();
+		goto again1;
+
+	case STSKIP:
+		goto again;
+
+	case STGARB:
+		if ((unsigned) ch - 040 < 0137)	{
+			lexerror("garbage char %c", ch);
+		}
+		else	lexerror("garbage char \\%03o", ch);
+		goto again;
+
+	case STSIMP:
+		if (ch == '(')	{
+			LoadChar(nch);
+			if (nch == '*')	{
+				SkipComment();
+				goto again;
+			}
+			else if (nch == EOI) eofseen = 1;
+			else PushBack();
+		}
+		if (ch == '&') return tk->tk_symb = AND;
+		if (ch == '~') return tk->tk_symb = NOT;
+		return tk->tk_symb = ch;
+
+	case STCOMP:
+		LoadChar(nch);
+		switch (ch)	{
+
+		case '.':
+			if (nch == '.')	{
+				return tk->tk_symb = UPTO;
+			}
+			break;
+
+		case ':':
+			if (nch == '=')	{
+				return tk->tk_symb = BECOMES;
+			}
+			break;
+
+		case '<':
+			if (nch == '=')	{
+				return tk->tk_symb = LESSEQUAL;
+			}
+			if (nch == '>') {
+				return tk->tk_symb = '#';
+			}
+			break;
+
+		case '>':
+			if (nch == '=')	{
+				return tk->tk_symb = GREATEREQUAL;
+			}
+			break;
+
+		default :
+			crash("(LLlex, STCOMP)");
+		}
+		if (nch == EOI) eofseen = 1;
+		else PushBack();
+		return tk->tk_symb = ch;
+
+	case STIDF:
+	{
+		register char *tag = &buf[0];
+		register struct idf *id;
+
+		do	{
+			if (tag - buf < idfsize) *tag++ = ch;
+			LoadChar(ch);
+		} while(in_idf(ch));
+
+		if (ch == EOI) eofseen = 1;
+		else PushBack();
+		*tag++ = '\0';
+
+		tk->TOK_IDF = id = str2idf(buf, 1);
+		return tk->tk_symb = id->id_reserved ? id->id_reserved : IDENT;
+	}
+
+	case STSTR: {
+		register struct string *str = GetString(ch);
+
+		if (str->s_length == 1) {
+			tk->TOK_INT = *(str->s_str) & 0377;
+			toktype = char_type;
+			free(str->s_str);
+			free((char *) str);
+		}
+		else {
+			tk->tk_data.tk_str = str;
+			toktype = standard_type(T_STRING, 1, str->s_length);
+		}
+		return tk->tk_symb = STRING;
+		}
+
+	case STNUM:
+	{
+		/*	The problem arising with the "parsing" of a number
+			is that we don't know the base in advance so we
+			have to read the number with the help of a rather
+			complex finite automaton.
+		*/
+		enum statetp {Oct,OptHex,Hex,Dec,OctEndOrHex,End,OptReal,Real};
+		register enum statetp state;
+		register int base;
+		register char *np = &buf[1];
+					/* allow a '-' to be added	*/
+
+		buf[0] = '-';
+		*np++ = ch;
+		state = is_oct(ch) ? Oct : Dec;
+		LoadChar(ch);
+		for (;;) {
+			switch(state) {
+			case Oct:
+				while (is_oct(ch))	{
+					if (np < &buf[NUMSIZE]) *np++ = ch;
+					LoadChar(ch);
+				}
+				if (ch == 'B' || ch == 'C') {
+					base = 8;
+					state = OctEndOrHex;
+					break;
+				}
+				/* Fall Through */
+			case Dec:
+				base = 10;
+				while (is_dig(ch))	{
+					if (np < &buf[NUMSIZE]) {
+						*np++ = ch;
+					}
+					LoadChar(ch);
+				}
+				if (ch == 'D') state = OptHex;
+				else if (is_hex(ch)) state = Hex;
+				else if (ch == '.') state = OptReal;
+				else {
+					state = End;
+					if (ch == 'H') base = 16;
+					else if (ch == EOI) eofseen = 1;
+					else PushBack();
+				}
+				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;
+					LoadChar(ch);
+				}
+				base = 16;
+				state = End;
+				if (ch != 'H') {
+					lexerror("H expected after hex number");
+					if (ch == EOI) eofseen = 1;
+					else PushBack();
+				}
+				break;
+
+			case OctEndOrHex:
+				if (np < &buf[NUMSIZE]) *np++ = ch;
+				LoadChar(ch);
+				if (ch == 'H') {
+					base = 16;
+					state = End;
+					break;
+				}
+				if (is_hex(ch)) {
+					state = Hex;
+					break;
+				}
+				if (ch == EOI) eofseen = 1;
+				else PushBack();
+				ch = *--np;
+				*np++ = '\0';
+				base = 8;
+				/* Fall through */
+				
+			case End:
+				*np = '\0';
+				if (np >= &buf[NUMSIZE]) {
+					tk->TOK_INT = 1;
+					lexerror("constant too long");
+				}
+				else {
+					np = &buf[1];
+					while (*np == '0') np++;
+					tk->TOK_INT = str2long(np, base);
+					if (strlen(np) > 14 /* ??? */ ||
+				    	    tk->TOK_INT < 0) {
+lexwarning(W_ORDINARY, "overflow in constant");
+					}
+				}
+				if (ch == 'C' && base == 8) {
+					toktype = char_type;
+					if (tk->TOK_INT<0 || tk->TOK_INT>255) {
+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;
+				}
+				else	toktype = card_type;
+				return tk->tk_symb = INTEGER;
+
+			case OptReal:
+				/*	The '.' could be the first of the '..'
+					token. At this point, we need a
+					look-ahead of two characters.
+				*/
+				LoadChar(ch);
+				if (ch == '.') {
+					/*	Indeed the '..' token
+					*/
+					PushBack();
+					PushBack();
+					state = End;
+					base = 10;
+					break;
+				}
+				state = Real;
+				break;
+			}
+			if (state == Real) break;
+		}
+
+		/* a real real constant */
+		if (np < &buf[NUMSIZE]) *np++ = '.';
+
+		toktype = real_type;
+
+		while (is_dig(ch)) {
+			/* 	Fractional part
+			*/
+			if (np < &buf[NUMSIZE]) *np++ = ch;
+			LoadChar(ch);
+		}
+
+		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 == '-') {
+				/*	Signed scalefactor
+				*/
+				if (np < &buf[NUMSIZE]) *np++ = ch;
+				LoadChar(ch);
+			}
+			if (is_dig(ch)) {
+				do {
+					if (np < &buf[NUMSIZE]) *np++ = ch;
+					LoadChar(ch);
+				} while (is_dig(ch));
+			}
+			else {
+				lexerror("bad scale factor");
+			}
+		}
+
+noscale:
+		*np++ = '\0';
+		if (ch == EOI) eofseen = 1;
+		else PushBack();
+
+		if (np >= &buf[NUMSIZE]) {
+			tk->TOK_REL = Salloc("0.0", 5);
+			lexerror("floating constant too long");
+		}
+		else	tk->TOK_REL = Salloc(buf, (unsigned) (np - buf)) + 1;
+		return tk->tk_symb = REAL;
+
+		/*NOTREACHED*/
+	}
+
+	case STEOI:
+		return tk->tk_symb = -1;
+
+	case STCHAR:
+	default:
+		crash("(LLlex) Impossible character class");
+		/*NOTREACHED*/
+	}
+	/*NOTREACHED*/
+}

lang/m2/comp/LLlex.h

@@ -0,0 +1,45 @@
+/*
+ * (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
+ */
+
+/* T O K E N   D E S C R I P T O R   D E F I N I T I O N */
+
+/* $Header$ */
+
+/* Structure to store a string constant
+*/
+struct string {
+	arith s_length;			/* length of a string */
+	char *s_str;			/* the string itself */
+};
+
+/* Token structure. Keep it small, as it is part of a parse-tree node
+*/
+struct token	{
+	short tk_symb;			/* token itself	*/
+	unsigned short tk_lineno;	/* linenumber on which it occurred */
+	union {
+		struct idf *tk_idf;	/* IDENT	*/
+		struct string *tk_str;	/* STRING	*/
+		arith tk_int;		/* INTEGER	*/
+		char *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 */
+	} tk_data;
+};
+
+#define TOK_IDF	tk_data.tk_idf
+#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
+
+extern struct token dot, aside;
+extern struct type *toktype;
+
+#define DOT	dot.tk_symb
+#define ASIDE	aside.tk_symb

lang/m2/comp/LLmessage.c

@@ -0,0 +1,67 @@
+/*
+ * (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
+ */
+
+/* S Y N T A X   E R R O R   R E P O R T I N G */
+
+/* $Header$ */
+
+/*	Defines the LLmessage routine. LLgen-generated parsers require the
+	existence of a routine of that name.
+	The routine must do syntax-error reporting and must be able to
+	insert tokens in the token stream.
+*/
+
+#include	<alloc.h>
+#include	<em_arith.h>
+#include	<em_label.h>
+
+#include	"idf.h"
+#include	"LLlex.h"
+#include	"Lpars.h"
+
+extern char		*symbol2str();
+extern struct idf	*gen_anon_idf();
+
+LLmessage(tk)
+	register int tk;
+{
+	if (tk > 0)	{
+		/* if (tk > 0), it represents the token to be inserted.
+		*/
+		register struct token *dotp = &dot;
+
+		error("%s missing", symbol2str(tk));
+
+		aside = *dotp;
+
+		dotp->tk_symb = tk;
+
+		switch (tk)	{
+		/* The operands need some body */
+		case IDENT:
+			dotp->TOK_IDF = gen_anon_idf();
+			break;
+		case STRING:
+			dotp->tk_data.tk_str = (struct string *)
+						Malloc(sizeof (struct string));
+			dotp->TOK_SLE = 1;
+			dotp->TOK_STR = Salloc("", 1);
+			break;
+		case INTEGER:
+			dotp->TOK_INT = 1;
+			break;
+		case REAL:
+			dotp->TOK_REL = Salloc("0.0", 4);
+			break;
+		}
+	}
+	else if (tk  < 0) {
+		error("garbage at end of program");
+	}
+	else	error("%s deleted", symbol2str(dot.tk_symb));
+}
+

lang/m2/comp/MakeVersion

@@ -0,0 +1,8 @@
+V=`cat Version.c`
+VERSION=`expr "$V" ':' '.*[0-9][0-9]*\.\([0-9][0-9]*\).*'`
+NEWVERSION=`expr $VERSION + 1`
+sed "s/\.$VERSION/.$NEWVERSION/" < Version.c > tmp$$
+mv tmp$$ Version.c
+CM "$*"
+V=`cat Version.c`
+SV > ../versions/V`expr "$V" ':' '.*\([0-9][0-9]*\.[0-9][0-9]*\).*'`

lang/m2/comp/Makefile

@@ -0,0 +1,419 @@
+# make modula-2 "compiler"
+EMHOME =		../../..
+MHDIR =		$(EMHOME)/modules/h
+PKGDIR =	$(EMHOME)/modules/pkg
+LIBDIR =	$(EMHOME)/modules/lib
+OBJECTCODE =	$(LIBDIR)/libemk.a
+LLGEN =		$(EMHOME)/bin/LLgen
+MKDEP =		$(EMHOME)/bin/mkdep
+PRID =		$(EMHOME)/bin/prid
+CID =		$(EMHOME)/bin/cid
+CURRDIR =	.
+
+INCLUDES = -I$(MHDIR) -I$(EMHOME)/h -I$(PKGDIR)
+
+GF =	program.g declar.g expression.g statement.g
+GENGFILES=	tokenfile.g
+GFILES =$(GENGFILES) $(GF)
+LLGENOPTIONS = -v
+PROFILE =
+CFLAGS = $(PROFILE) $(INCLUDES) -O -DSTATIC=
+LINTFLAGS = -DSTATIC= -DNORCSID
+MALLOC = $(LIBDIR)/malloc.o
+LDFLAGS = -i $(PROFILE)
+LSRC =	tokenfile.c program.c declar.c expression.c statement.c
+LOBJ =	tokenfile.o program.o declar.o expression.o statement.o
+CSRC =	LLlex.c LLmessage.c error.c main.c \
+	tokenname.c idf.c input.c type.c def.c \
+	misc.c enter.c defmodule.c typequiv.c node.c \
+	cstoper.c chk_expr.c options.c walk.c desig.c \
+	code.c lookup.c Version.c
+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 \
+	cstoper.o chk_expr.o options.o walk.o casestat.o desig.o \
+	code.o tmpvar.o lookup.o Version.o next.o
+GENC=	$(LSRC) symbol2str.c char.c Lpars.c casestat.c tmpvar.c scope.c next.c
+SRC =	$(CSRC) $(GENC)
+OBJ =	$(COBJ) $(LOBJ) Lpars.o
+
+GENH=	errout.h\
+	idfsize.h numsize.h strsize.h target_sizes.h \
+	inputtype.h maxset.h density.h\
+	def.h debugcst.h type.h Lpars.h node.h desig.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
+
+#EXCLEXCLEXCLEXCL
+
+all:	Cfiles
+	sh -c 'if $(CC) nmclash.c > /dev/null 2>&1 ; then make "EMHOME="$(EMHOME) $(CURRDIR)/main ; else EMHOME=$(EMHOME); export EMHOME; sh Resolve main ; fi'
+	@rm -f nmclash.o a.out
+
+install:	all
+	cp $(CURRDIR)/main $(EMHOME)/lib/em_m2
+	rm -f $(EMHOME)/man/em_m2.6 $(EMHOME)/man/modula-2.1
+	cp $(CURRDIR)/em_m2.6 $(CURRDIR)/modula-2.1 $(EMHOME)/man
+
+cmp:	all
+	-cmp $(CURRDIR)/main $(EMHOME)/lib/em_m2
+	-cmp $(CURRDIR)/em_m2.6 $(EMHOME)/man/em_m2.6 
+	-cmp $(CURRDIR)/modula-2.1 $(EMHOME)/man/modula-2.1 
+
+opr:
+	make pr | opr
+
+pr:
+	@pr Makefile Resolve Parameters $(GF) *.H $(HFILES) *.C $(CSRC)
+
+clean:
+	rm -f $(OBJ) $(GENFILES) LLfiles hfiles Cfiles tab clashes \
+		$(CURRDIR)/main LL.output
+	(cd .. ; rm -rf Xsrc)
+
+lint:	Cfiles
+	sh -c 'if $(CC) nmclash.c > /dev/null 2>&1 ; then make "EMHOME="$(EMHOME) Xlint ; else EMHOME=$(EMHOME); export EMHOME; sh Resolve Xlint ; fi'
+	@rm -f nmclash.o a.out
+
+longnames:	$(SRC) $(HFILES)
+	sh -c 'if test -f longnames ; then $(PRID) -l7 longnames $? > Xlongnames ; mv Xlongnames longnames ; else $(PRID) -l7 $? > longnames ; fi'
+
+# entry points not to be used directly
+
+Cfiles:	hfiles LLfiles $(GENC) $(GENH) Makefile
+	echo $(SRC) $(HFILES) > Cfiles
+
+LLfiles:	$(GFILES)
+	$(LLGEN) $(LLGENOPTIONS) $(GFILES)
+	@touch LLfiles
+
+hfiles:	Parameters make.hfiles
+	make.hfiles Parameters
+	touch hfiles
+
+tokenfile.g:	tokenname.c make.tokfile
+	make.tokfile <tokenname.c >tokenfile.g
+
+symbol2str.c:	tokenname.c make.tokcase
+	make.tokcase <tokenname.c >symbol2str.c
+
+.SUFFIXES:	.H .h
+.H.h:
+		./make.allocd < $*.H > $*.h
+
+.SUFFIXES:	.C .c
+.C.c:
+		./make.allocd < $*.C > $*.c
+
+def.h:		make.allocd
+type.h:		make.allocd
+node.h:		make.allocd
+desig.h:	make.allocd
+scope.c:	make.allocd
+tmpvar.c:	make.allocd
+casestat.c:	make.allocd
+
+next.c:		$(NEXTFILES) ./make.next
+		./make.next $(NEXTFILES) > next.c
+
+char.c: char.tab tab
+	tab -fchar.tab >char.c
+
+tab: 
+	$(CC) tab.c -o tab
+
+depend:
+	sed '/^#AUTOAUTO/,$$d' Makefile > Makefile.new
+	echo '#AUTOAUTOAUTOAUTOAUTOAUTOAUTOAUTO' >> Makefile.new
+	$(MKDEP) $(SRC) |\
+		sed 's/\.c:/\.o:/' >> Makefile.new
+	mv Makefile Makefile.old
+	mv Makefile.new Makefile
+
+#INCLINCLINCLINCL
+
+Xlint:
+	lint $(INCLUDES) $(LINTFLAGS) $(SRC) \
+		$(LIBDIR)/llib-lem_mes.ln \
+		$(LIBDIR)/llib-lemk.ln \
+		$(LIBDIR)/llib-linput.ln \
+		$(LIBDIR)/llib-lassert.ln \
+		$(LIBDIR)/llib-lalloc.ln \
+		$(LIBDIR)/llib-lprint.ln \
+		$(LIBDIR)/llib-lstring.ln \
+		$(LIBDIR)/llib-lsystem.ln
+
+$(CURRDIR)/main:	$(OBJ)
+	$(CC) $(LDFLAGS) $(OBJ) $(LIBDIR)/libem_mes.a $(OBJECTCODE) $(LIBDIR)/libinput.a $(LIBDIR)/libassert.a $(LIBDIR)/liballoc.a $(MALLOC) $(LIBDIR)/libprint.a $(LIBDIR)/libstring.a $(LIBDIR)/libsystem.a -o $(CURRDIR)/main
+	size $(CURRDIR)/main
+
+#AUTOAUTOAUTOAUTOAUTOAUTOAUTOAUTO
+LLlex.o: LLlex.h
+LLlex.o: Lpars.h
+LLlex.o: class.h
+LLlex.o: const.h
+LLlex.o: debug.h
+LLlex.o: debugcst.h
+LLlex.o: def.h
+LLlex.o: f_info.h
+LLlex.o: idf.h
+LLlex.o: idfsize.h
+LLlex.o: input.h
+LLlex.o: inputtype.h
+LLlex.o: numsize.h
+LLlex.o: strsize.h
+LLlex.o: type.h
+LLlex.o: warning.h
+LLmessage.o: LLlex.h
+LLmessage.o: Lpars.h
+LLmessage.o: idf.h
+error.o: LLlex.h
+error.o: debug.h
+error.o: debugcst.h
+error.o: errout.h
+error.o: f_info.h
+error.o: input.h
+error.o: inputtype.h
+error.o: main.h
+error.o: node.h
+error.o: warning.h
+main.o: LLlex.h
+main.o: Lpars.h
+main.o: SYSTEM.h
+main.o: debug.h
+main.o: debugcst.h
+main.o: def.h
+main.o: f_info.h
+main.o: idf.h
+main.o: input.h
+main.o: inputtype.h
+main.o: node.h
+main.o: scope.h
+main.o: standards.h
+main.o: tokenname.h
+main.o: type.h
+main.o: warning.h
+tokenname.o: Lpars.h
+tokenname.o: idf.h
+tokenname.o: tokenname.h
+idf.o: idf.h
+input.o: f_info.h
+input.o: input.h
+input.o: inputtype.h
+type.o: LLlex.h
+type.o: chk_expr.h
+type.o: const.h
+type.o: debug.h
+type.o: debugcst.h
+type.o: def.h
+type.o: idf.h
+type.o: maxset.h
+type.o: node.h
+type.o: scope.h
+type.o: target_sizes.h
+type.o: type.h
+type.o: walk.h
+def.o: LLlex.h
+def.o: Lpars.h
+def.o: debug.h
+def.o: debugcst.h
+def.o: def.h
+def.o: idf.h
+def.o: main.h
+def.o: node.h
+def.o: scope.h
+def.o: type.h
+misc.o: LLlex.h
+misc.o: f_info.h
+misc.o: idf.h
+misc.o: misc.h
+misc.o: node.h
+enter.o: LLlex.h
+enter.o: debug.h
+enter.o: debugcst.h
+enter.o: def.h
+enter.o: f_info.h
+enter.o: idf.h
+enter.o: main.h
+enter.o: misc.h
+enter.o: node.h
+enter.o: scope.h
+enter.o: type.h
+defmodule.o: LLlex.h
+defmodule.o: Lpars.h
+defmodule.o: debug.h
+defmodule.o: debugcst.h
+defmodule.o: def.h
+defmodule.o: f_info.h
+defmodule.o: idf.h
+defmodule.o: input.h
+defmodule.o: inputtype.h
+defmodule.o: main.h
+defmodule.o: misc.h
+defmodule.o: node.h
+defmodule.o: scope.h
+defmodule.o: type.h
+typequiv.o: LLlex.h
+typequiv.o: debug.h
+typequiv.o: debugcst.h
+typequiv.o: def.h
+typequiv.o: idf.h
+typequiv.o: node.h
+typequiv.o: type.h
+typequiv.o: warning.h
+node.o: LLlex.h
+node.o: debug.h
+node.o: debugcst.h
+node.o: def.h
+node.o: node.h
+node.o: type.h
+cstoper.o: LLlex.h
+cstoper.o: Lpars.h
+cstoper.o: debug.h
+cstoper.o: debugcst.h
+cstoper.o: idf.h
+cstoper.o: node.h
+cstoper.o: standards.h
+cstoper.o: target_sizes.h
+cstoper.o: type.h
+cstoper.o: warning.h
+chk_expr.o: LLlex.h
+chk_expr.o: Lpars.h
+chk_expr.o: chk_expr.h
+chk_expr.o: const.h
+chk_expr.o: debug.h
+chk_expr.o: debugcst.h
+chk_expr.o: def.h
+chk_expr.o: idf.h
+chk_expr.o: misc.h
+chk_expr.o: node.h
+chk_expr.o: scope.h
+chk_expr.o: standards.h
+chk_expr.o: type.h
+chk_expr.o: warning.h
+options.o: idfsize.h
+options.o: main.h
+options.o: type.h
+options.o: warning.h
+walk.o: LLlex.h
+walk.o: Lpars.h
+walk.o: chk_expr.h
+walk.o: debug.h
+walk.o: debugcst.h
+walk.o: def.h
+walk.o: desig.h
+walk.o: f_info.h
+walk.o: idf.h
+walk.o: main.h
+walk.o: node.h
+walk.o: scope.h
+walk.o: type.h
+walk.o: walk.h
+walk.o: warning.h
+desig.o: LLlex.h
+desig.o: debug.h
+desig.o: debugcst.h
+desig.o: def.h
+desig.o: desig.h
+desig.o: node.h
+desig.o: scope.h
+desig.o: type.h
+code.o: LLlex.h
+code.o: Lpars.h
+code.o: debug.h
+code.o: debugcst.h
+code.o: def.h
+code.o: desig.h
+code.o: node.h
+code.o: scope.h
+code.o: standards.h
+code.o: type.h
+code.o: walk.h
+lookup.o: LLlex.h
+lookup.o: debug.h
+lookup.o: debugcst.h
+lookup.o: def.h
+lookup.o: idf.h
+lookup.o: misc.h
+lookup.o: node.h
+lookup.o: scope.h
+lookup.o: type.h
+tokenfile.o: Lpars.h
+program.o: LLlex.h
+program.o: Lpars.h
+program.o: debug.h
+program.o: debugcst.h
+program.o: def.h
+program.o: f_info.h
+program.o: idf.h
+program.o: main.h
+program.o: node.h
+program.o: scope.h
+program.o: type.h
+program.o: warning.h
+declar.o: LLlex.h
+declar.o: Lpars.h
+declar.o: chk_expr.h
+declar.o: debug.h
+declar.o: debugcst.h
+declar.o: def.h
+declar.o: idf.h
+declar.o: main.h
+declar.o: misc.h
+declar.o: node.h
+declar.o: scope.h
+declar.o: type.h
+declar.o: warning.h
+expression.o: LLlex.h
+expression.o: Lpars.h
+expression.o: chk_expr.h
+expression.o: const.h
+expression.o: debug.h
+expression.o: debugcst.h
+expression.o: def.h
+expression.o: idf.h
+expression.o: node.h
+expression.o: type.h
+expression.o: warning.h
+statement.o: LLlex.h
+statement.o: Lpars.h
+statement.o: def.h
+statement.o: idf.h
+statement.o: node.h
+statement.o: scope.h
+statement.o: type.h
+symbol2str.o: Lpars.h
+char.o: class.h
+Lpars.o: Lpars.h
+casestat.o: LLlex.h
+casestat.o: Lpars.h
+casestat.o: chk_expr.h
+casestat.o: debug.h
+casestat.o: debugcst.h
+casestat.o: density.h
+casestat.o: desig.h
+casestat.o: node.h
+casestat.o: type.h
+casestat.o: walk.h
+tmpvar.o: LLlex.h
+tmpvar.o: debug.h
+tmpvar.o: debugcst.h
+tmpvar.o: def.h
+tmpvar.o: main.h
+tmpvar.o: scope.h
+tmpvar.o: type.h
+scope.o: LLlex.h
+scope.o: debug.h
+scope.o: debugcst.h
+scope.o: def.h
+scope.o: idf.h
+scope.o: node.h
+scope.o: scope.h
+scope.o: type.h
+next.o: debug.h
+next.o: debugcst.h

lang/m2/comp/Parameters

@@ -0,0 +1,61 @@
+!File: errout.h
+#define	ERROUT		STDERR	/* file pointer for writing messages	*/
+#define	MAXERR_LINE	100	/* maximum number of error messages given
+					on the same input line.		*/
+
+
+!File: idfsize.h
+#define	IDFSIZE	128	/* maximum significant length of an identifier	*/
+
+
+!File: numsize.h
+#define	NUMSIZE	256	/* maximum length of a numeric constant		*/
+
+
+!File: strsize.h
+#define ISTRSIZE	32	/* minimum number of bytes allocated for
+					storing a string		*/
+#define RSTRSIZE	8	/* step size in enlarging the memory for
+					the storage of a string		*/
+
+
+!File: target_sizes.h
+#define MAXSIZE		8	/* the maximum of the SZ_* constants	*/
+
+/* target machine sizes	*/
+#define	SZ_CHAR		(arith)1
+#define	SZ_SHORT	(arith)2
+#define SZ_WORD		(arith)4
+#define	SZ_INT		(arith)4
+#define	SZ_LONG		(arith)4
+#define	SZ_FLOAT	(arith)4
+#define	SZ_DOUBLE	(arith)8
+#define	SZ_POINTER	(arith)4
+
+/* target machine alignment requirements	*/
+#define	AL_CHAR		1
+#define	AL_SHORT	(int)SZ_SHORT
+#define AL_WORD		(int)SZ_WORD
+#define	AL_INT		(int)SZ_WORD
+#define	AL_LONG		(int)SZ_WORD
+#define	AL_FLOAT	(int)SZ_WORD
+#define	AL_DOUBLE	(int)SZ_WORD
+#define	AL_POINTER	(int)SZ_WORD
+#define AL_STRUCT	1
+#define AL_UNION	1
+
+
+!File: debugcst.h
+#define DEBUG		1	/* perform various self-tests		*/
+
+!File: inputtype.h
+#define INP_READ_IN_ONE	1	/* read input file in one	*/
+
+
+!File: maxset.h
+#define MAXSET	1024		/* maximum number of elements in a set,
+				   but what is a reasonable choice ???
+				*/
+
+!File: density.h
+#define DENSITY	3		/* see casestat.C for an explanation */

lang/m2/comp/Resolve

@@ -0,0 +1,54 @@
+: create a directory Xsrc with name clashes resolved
+: and run make in that directory
+
+case $# in
+1)	
+	;;
+*)	echo "$0: one argument expected" 1>&2
+	exit 1
+	;;
+esac
+currdir=`pwd`
+case $1 in
+main)	target=$currdir/$1
+	;;
+Xlint)	target=$1
+	;;
+*)	echo "$0: $1: Illegal argument" 1>&2
+	exit 1
+	;;
+esac
+if test -d ../Xsrc
+then
+	:
+else	mkdir ../Xsrc
+fi
+make EMHOME=$EMHOME longnames
+: remove code generating routines from the clashes list as they are defines.
+: code generating routine names start with C_
+sed '/^C_/d' < longnames > tmp$$
+cclash -c -l7 tmp$$ > ../Xsrc/Xclashes
+rm -f tmp$$
+PW=`pwd`
+cd ../Xsrc
+if cmp -s Xclashes clashes
+then
+	:
+else
+	mv Xclashes clashes
+fi
+rm -f Makefile
+ed - $PW/Makefile <<'EOF'
+/^#EXCLEXCL/,/^#INCLINCL/d
+w Makefile
+q
+EOF
+for i in `cat $PW/Cfiles`
+do
+	cat >> Makefile <<EOF
+
+$i:	clashes $PW/$i
+	\$(CID) -Fclashes < $PW/$i > $i
+EOF
+done
+make EMHOME=$EMHOME CURRDIR=$currdir $target

lang/m2/comp/SYSTEM.h

@@ -0,0 +1,18 @@
+/*
+ * (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
+ */
+
+/* S Y S T E M   M O D U L E   T E X T */
+
+/* $Header$ */
+
+/* Text of SYSTEM module, for as far as it can be expressed in Modula-2 */
+
+#define SYSTEMTEXT "DEFINITION MODULE SYSTEM;\n\
+TYPE	PROCESS = ADDRESS;\n\
+PROCEDURE NEWPROCESS(P:PROC; A:ADDRESS; n:CARDINAL; VAR p1:ADDRESS);\n\
+PROCEDURE TRANSFER(VAR p1,p2:ADDRESS);\n\
+END SYSTEM.\n"

lang/m2/comp/Version.c

@@ -0,0 +1 @@
+static char Version[] = "ACK Modula-2 compiler Version 0.15";

lang/m2/comp/casestat.C

@@ -0,0 +1,318 @@
+/*
+ * (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
+ */
+
+/* C A S E   S T A T E M E N T   C O D E   G E N E R A T I O N */
+
+/* $Header$ */
+
+/*	Generation of case statements is done by first creating a
+	description structure for the statement, build a list of the
+	case-labels, then generating a case description in the code,
+	and generating either CSA or CSB, and then generating code for the
+	cases themselves.
+*/
+
+#include	"debug.h"
+
+#include	<em_label.h>
+#include	<em_arith.h>
+#include	<em_code.h>
+#include	<alloc.h>
+#include	<assert.h>
+
+#include	"Lpars.h"
+#include	"type.h"
+#include	"LLlex.h"
+#include	"node.h"
+#include	"desig.h"
+#include	"walk.h"
+#include	"chk_expr.h"
+
+#include	"density.h"
+
+struct switch_hdr	{
+	label sh_break;			/* label of statement after this one */
+	label sh_default;		/* label of ELSE part, or 0 */
+	int sh_nrofentries;		/* number of cases */
+	struct type *sh_type;		/* type of case expression */
+	arith sh_lowerbd;		/* lowest case label */
+	arith sh_upperbd;		/* highest case label */
+	struct case_entry *sh_entries;	/* the cases with their generated
+					   labels
+					*/
+};
+
+/* STATICALLOCDEF "switch_hdr" 5 */
+
+struct case_entry	{
+	struct case_entry *ce_next;	/* next in list */
+	label ce_label;			/* generated label */
+	arith ce_value;			/* value of case label */
+};
+
+/* STATICALLOCDEF "case_entry" 20 */
+
+/* The constant DENSITY determines when CSA and when CSB instructions
+   are generated. Reasonable values are: 2, 3, 4.
+   On machines that have lots of address space and memory, higher values
+   might also be reasonable. On these machines the density of jump tables
+   may be lower.
+*/
+#define	compact(nr, low, up)	(nr != 0 && (up - low) / nr <= DENSITY)
+
+CaseCode(nd, exitlabel)
+	struct node *nd;
+	label exitlabel;
+{
+	/*	Check the expression, stack a new case header and
+		fill in the necessary fields.
+		"exitlabel" is the exit-label of the closest enclosing
+		LOOP-statement, or 0.
+	*/
+	register struct switch_hdr *sh = new_switch_hdr();
+	register struct node *pnode = nd;
+	register struct case_entry *ce;
+	register arith val;
+	label CaseDescrLab;
+	int casecnt = 0;
+
+	assert(pnode->nd_class == Stat && pnode->nd_symb == CASE);
+
+	if (ChkExpression(pnode->nd_left)) {
+		MkCoercion(&(pnode->nd_left),BaseType(pnode->nd_left->nd_type));
+		CodePExpr(pnode->nd_left);
+	}
+	sh->sh_type = pnode->nd_left->nd_type;
+	sh->sh_break = ++text_label;
+
+	/* Now, create case label list
+	*/
+	while (pnode = pnode->nd_right) {
+		if (pnode->nd_class == Link && pnode->nd_symb == '|') {
+			if (pnode->nd_left) {
+				/* non-empty case
+				*/
+				pnode->nd_lab = ++text_label;
+				casecnt++;
+				if (! AddCases(sh, /* to descriptor */
+					       pnode->nd_left->nd_left,
+						   /* of case labels */
+					       pnode->nd_lab
+						   /* and code label */
+					      )) {
+					FreeSh(sh);
+					return;
+				}
+			}
+		}
+		else {
+			/* Else part
+			*/
+
+			sh->sh_default = ++text_label;
+			break;
+		}
+	}
+
+	if (!casecnt) {
+		/* There were no cases, so we have to check the case-expression
+		   here
+		*/
+		if (! (sh->sh_type->tp_fund & T_DISCRETE)) {
+			node_error(nd, "illegal type in CASE-expression");
+			FreeSh(sh);
+			return;
+		}
+	}
+
+	/* Now generate code for the switch itself
+	   First the part that CSA and CSB descriptions have in common.
+	*/
+	CaseDescrLab = ++data_label;	/* the rom must have a label	*/
+	C_df_dlb(CaseDescrLab);
+	if (sh->sh_default) C_rom_ilb(sh->sh_default);
+	else C_rom_ucon("0", pointer_size);
+	if (compact(sh->sh_nrofentries, sh->sh_lowerbd, sh->sh_upperbd)) {
+		/* CSA
+		*/
+		C_rom_cst(sh->sh_lowerbd);
+		C_rom_cst(sh->sh_upperbd - sh->sh_lowerbd);
+		ce = sh->sh_entries;
+		for (val = sh->sh_lowerbd; val <= sh->sh_upperbd; val++) {
+			assert(ce);
+			if (val == ce->ce_value)	{
+				C_rom_ilb(ce->ce_label);
+				ce = ce->ce_next;
+			}
+			else if (sh->sh_default) C_rom_ilb(sh->sh_default);
+			else C_rom_ucon("0", pointer_size);
+		}
+		C_lae_dlb(CaseDescrLab, (arith)0);	/* perform the switch */
+		C_csa(word_size);
+	}
+	else	{ 
+		/* CSB
+		*/
+		C_rom_cst((arith)sh->sh_nrofentries);
+		for (ce = sh->sh_entries; ce; ce = ce->ce_next)	{
+			/* generate the entries: value + prog.label
+			*/
+			C_rom_cst(ce->ce_value);
+			C_rom_ilb(ce->ce_label);
+		}
+		C_lae_dlb(CaseDescrLab, (arith)0);	/* perform the switch */
+		C_csb(word_size);
+	}
+
+	/* Now generate code for the cases
+	*/
+	pnode = nd;
+	while (pnode = pnode->nd_right) {
+		if (pnode->nd_class == Link && pnode->nd_symb == '|') {
+			if (pnode->nd_left) {
+				C_df_ilb(pnode->nd_lab);
+				WalkNode(pnode->nd_left->nd_right, exitlabel);
+				C_bra(sh->sh_break);
+			}
+		}
+		else {
+			/* Else part
+			*/
+			assert(sh->sh_default != 0);
+
+			C_df_ilb(sh->sh_default);
+			WalkNode(pnode, exitlabel);
+			break;
+		}
+	}
+
+	C_df_ilb(sh->sh_break);
+	FreeSh(sh);
+}
+
+FreeSh(sh)
+	register struct switch_hdr *sh;
+{
+	/*	 free the allocated switch structure	
+	*/
+	register struct case_entry *ce;
+
+	ce = sh->sh_entries;
+	while (ce)	{
+		struct case_entry *tmp = ce->ce_next;
+
+		free_case_entry(ce);
+		ce = tmp;
+	}
+
+	free_switch_hdr(sh);
+}
+
+AddCases(sh, node, lbl)
+	struct switch_hdr *sh;
+	register struct node *node;
+	label lbl;
+{
+	/*	Add case labels to the case label list
+	*/
+	register arith v1, v2;
+
+	if (node->nd_class == Link) {
+		if (node->nd_symb == UPTO) {
+			assert(node->nd_left->nd_class == Value);
+			assert(node->nd_right->nd_class == Value);
+
+			v2 = node->nd_right->nd_INT;
+			node->nd_type = node->nd_left->nd_type;
+			for (v1 = node->nd_left->nd_INT; v1 <= v2; v1++) {
+				node->nd_INT = v1;
+				if (! AddOneCase(sh, node, lbl)) return 0;
+			}
+			return 1;
+		}
+
+		assert(node->nd_symb == ',');
+		return	AddCases(sh, node->nd_left, lbl) &&
+		    	AddCases(sh, node->nd_right, lbl);
+	}
+
+	assert(node->nd_class == Value);
+	return AddOneCase(sh, node, lbl);
+}
+
+AddOneCase(sh, node, lbl)
+	register struct switch_hdr *sh;
+	struct node *node;
+	label lbl;
+{
+	register struct case_entry *ce = new_case_entry();
+	register struct case_entry *c1 = sh->sh_entries, *c2 = 0;
+
+	ce->ce_label = lbl;
+	ce->ce_value = node->nd_INT;
+	if (! ChkCompat(&node, sh->sh_type, "case")) {
+		free_case_entry(ce);
+		return 0;
+	}
+	if (sh->sh_entries == 0)	{
+		/* first case entry
+		*/
+		ce->ce_next = (struct case_entry *) 0;
+		sh->sh_entries = ce;
+		sh->sh_lowerbd = sh->sh_upperbd = ce->ce_value;
+		sh->sh_nrofentries = 1;
+	}
+	else	{
+		/* second etc. case entry
+		   find the proper place to put ce into the list
+		*/
+		
+		if (ce->ce_value < sh->sh_lowerbd) {
+			sh->sh_lowerbd = ce->ce_value;
+		}
+		else if (ce->ce_value > sh->sh_upperbd) {
+			sh->sh_upperbd = ce->ce_value;
+		}
+		while (c1 && c1->ce_value < ce->ce_value)	{
+			c2 = c1;
+			c1 = c1->ce_next;
+		}
+		/*	At this point three cases are possible:
+			1: c1 != 0 && c2 != 0:
+				insert ce somewhere in the middle
+			2: c1 != 0 && c2 == 0:
+				insert ce right after the head
+			3: c1 == 0 && c2 != 0:
+				append ce to last element
+			The case c1 == 0 && c2 == 0 cannot occur, since
+			the list is guaranteed not to be empty.
+		*/
+		if (c1)	{
+			if (c1->ce_value == ce->ce_value)	{
+node_error(node, "multiple case entry for value %ld", ce->ce_value);
+				free_case_entry(ce);
+				return 0;
+			}
+			if (c2)	{
+				ce->ce_next = c2->ce_next;
+				c2->ce_next = ce;
+			}
+			else	{
+				ce->ce_next = sh->sh_entries;
+				sh->sh_entries = ce;
+			}
+		}
+		else	{
+			assert(c2);
+
+			ce->ce_next = (struct case_entry *) 0;
+			c2->ce_next = ce;
+		}
+		(sh->sh_nrofentries)++;
+	}
+	return 1;
+}

lang/m2/comp/char.tab

@@ -0,0 +1,54 @@
+% character tables for mod2 compiler
+% $Header$
+%S129
+%F	%s,
+%
+%	CHARACTER CLASSES
+%
+%C
+STGARB:\000-\200
+STSKIP: \r\t
+STNL:\012\013\014
+STSIMP:#&()*+,-/;=[]^{|}~
+STCOMP:.:<>
+STIDF:a-zA-Z
+STSTR:"'
+STNUM:0-9
+STEOI:\200
+%T#include "class.h"
+%Tchar tkclass[] = {
+%p
+%T};
+%
+%	INIDF
+%
+%C
+1:a-zA-Z0-9
+%Tchar inidf[] = {
+%F	%s,
+%p
+%T};
+%
+%	ISDIG
+%
+%C
+1:0-9
+%Tchar isdig[] = {
+%p
+%T};
+%
+%	ISHEX
+%
+%C
+1:a-fA-F
+%Tchar ishex[] = {
+%p
+%T};
+%
+%	ISOCT
+%
+%C
+1:0-7
+%Tchar isoct[] = {
+%p
+%T};

lang/m2/comp/chk_expr.h

@@ -0,0 +1,20 @@
+/*
+ * (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
+ */
+
+/* E X P R E S S I O N   C H E C K I N G */
+
+/* $Header$ */
+
+extern int	(*ExprChkTable[])();	/* table of expression checking
+					   functions, indexed by node class
+					*/
+extern int	(*DesigChkTable[])();	/* table of designator checking
+					   functions, indexed by node class
+					*/
+
+#define	ChkExpression(expp)	((*ExprChkTable[(expp)->nd_class])(expp))
+#define ChkDesignator(expp)	((*DesigChkTable[(expp)->nd_class])(expp))

lang/m2/comp/class.h

@@ -0,0 +1,45 @@
+/*
+ * (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
+ */
+
+/* U S E   O F   C H A R A C T E R   C L A S S E S */
+
+/* $Header$ */
+
+/*	As a starter, chars are divided into classes, according to which
+	token they can be the start of.
+	At present such a class number is supposed to fit in 4 bits.
+*/
+
+#define	class(ch)	(tkclass[ch])
+
+/*	Being the start of a token is, fortunately, a mutual exclusive
+	property, so, as there are less than 16 classes they can be
+	packed in 4 bits.
+*/
+
+#define	STSKIP	0	/* spaces and so on: skipped characters		*/
+#define	STNL	1	/* newline character(s): update linenumber etc.	*/
+#define	STGARB	2	/* garbage ascii character: not allowed		*/
+#define	STSIMP	3	/* this character can occur as token		*/
+#define	STCOMP	4	/* this one can start a compound token		*/
+#define	STIDF	5	/* being the initial character of an identifier	*/
+#define	STCHAR	6	/* the starter of a character constant		*/
+#define	STSTR	7	/* the starter of a string			*/
+#define	STNUM	8	/* the starter of a numeric constant		*/
+#define	STEOI	9	/* End-Of-Information mark			*/
+
+/*	But occurring inside a token is not, so we need 1 bit for each
+	class.  This is implemented as a collection of tables to speed up
+	the decision whether a character has a special meaning.
+*/
+#define	in_idf(ch)	((unsigned)ch < 0177 && inidf[ch])
+#define	is_oct(ch)	((unsigned)ch < 0177 && isoct[ch])
+#define	is_dig(ch)	((unsigned)ch < 0177 && isdig[ch])
+#define	is_hex(ch)	((unsigned)ch < 0177 && ishex[ch])
+
+extern char tkclass[];
+extern char inidf[], isoct[], isdig[], ishex[];

lang/m2/comp/const.h

@@ -0,0 +1,21 @@
+/*
+ * (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
+ */
+
+/* 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	*/
+extern unsigned int
+	wrd_bits;	/* Number of bits in a word */

lang/m2/comp/cstoper.c

@@ -0,0 +1,496 @@
+/*
+ * (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
+ */
+
+/* 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 */
+
+/* $Header$ */
+
+#include	"debug.h"
+#include	"target_sizes.h"
+
+#include	<em_arith.h>
+#include	<em_label.h>
+#include	<assert.h>
+
+#include	"idf.h"
+#include	"type.h"
+#include	"LLlex.h"
+#include	"node.h"
+#include	"Lpars.h"
+#include	"standards.h"
+#include	"warning.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, .. */
+long int_mask[MAXSIZE];	/* int_mask[1] == 0x7F, int_mask[2] == 0x7FFF, .. */
+arith max_int;		/* maximum integer on target machine	*/
+arith max_unsigned;	/* maximum unsigned on target machine	*/
+arith max_longint;	/* maximum longint on target machine	*/
+unsigned int wrd_bits;	/* number of bits in a word */
+
+extern char options[];
+
+static char ovflow[] = "overflow in constant expression";
+
+cstunary(expp)
+	register struct node *expp;
+{
+	/*	The unary operation in "expp" is performed on the constant
+		expression below it, and the result restored in expp.
+	*/
+	register struct node *right = expp->nd_right;
+
+	switch(expp->nd_symb) {
+	/* Should not get here
+	case '+':
+		break;
+	*/
+
+	case '-':
+		expp->nd_INT = -right->nd_INT;
+		if (expp->nd_type->tp_fund == T_INTORCARD) {
+			expp->nd_type = int_type;
+		}
+		break;
+
+	case NOT:
+	case '~':
+		expp->nd_INT = !right->nd_INT;
+		break;
+
+	default:
+		crash("(cstunary)");
+	}
+
+	expp->nd_class = Value;
+	expp->nd_symb = right->nd_symb;
+	CutSize(expp);
+	FreeNode(right);
+	expp->nd_right = 0;
+}
+
+cstbin(expp)
+	register struct node *expp;
+{
+	/*	The binary operation in "expp" is performed on the constant
+		expressions below it, and the result restored in
+		expp.
+	*/
+	register arith o1 = expp->nd_left->nd_INT;
+	register arith o2 = expp->nd_right->nd_INT;
+	register int uns = expp->nd_left->nd_type != int_type;
+
+	assert(expp->nd_class == Oper);
+	assert(expp->nd_left->nd_class == Value);
+	assert(expp->nd_right->nd_class == Value);
+
+	switch (expp->nd_symb)	{
+	case '*':
+		o1 *= o2;
+		break;
+
+	case DIV:
+		if (o2 == 0)	{
+			node_error(expp, "division by 0");
+			return;
+		}
+		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 MOD:
+		if (o2 == 0)	{
+			node_error(expp, "modulo by 0");
+			return;
+		}
+		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;
+		if (expp->nd_type->tp_fund == T_INTORCARD) {
+			if (o1 < 0) expp->nd_type = int_type;
+		}
+		break;
+
+	case '<':
+		{	arith tmp = o1;
+			
+			o1 = o2;
+			o2 = tmp;
+		}
+		/* Fall through */
+
+	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 LESSEQUAL:
+		{	arith tmp = o1;
+			
+			o1 = o2;
+			o2 = tmp;
+		}
+		/* Fall through */
+
+	case GREATEREQUAL:
+		o1 = chk_bounds(o2, o1, uns ? T_CARDINAL : T_INTEGER);
+		break;
+
+	case '=':
+		o1 = (o1 == o2);
+		break;
+
+	case '#':
+		o1 = (o1 != o2);
+		break;
+
+	case AND:
+	case '&':
+		o1 = (o1 && o2);
+		break;
+
+	case OR:
+		o1 = (o1 || o2);
+		break;
+
+	default:
+		crash("(cstbin)");
+	}
+
+	expp->nd_class = Value;
+	expp->nd_token = expp->nd_right->nd_token;
+	if (expp->nd_type == bool_type) expp->nd_symb = INTEGER;
+	expp->nd_INT = o1;
+	CutSize(expp);
+	FreeNode(expp->nd_left);
+	FreeNode(expp->nd_right);
+	expp->nd_left = expp->nd_right = 0;
+}
+
+cstset(expp)
+	register struct node *expp;
+{
+	register arith *set1, *set2;
+	arith *resultset = 0;
+	register unsigned int setsize;
+	register int j;
+
+	assert(expp->nd_right->nd_class == Set);
+	assert(expp->nd_symb == IN || expp->nd_left->nd_class == Set);
+
+	set2 = expp->nd_right->nd_set;
+	setsize = (unsigned) expp->nd_right->nd_type->tp_size / (unsigned) word_size;
+
+	if (expp->nd_symb == IN) {
+		unsigned i;
+
+		assert(expp->nd_left->nd_class == Value);
+
+		i = expp->nd_left->nd_INT;
+		expp->nd_class = Value;
+		expp->nd_INT = (expp->nd_left->nd_INT >= 0 &&
+				expp->nd_left->nd_INT < setsize * wrd_bits &&
+		    (set2[i / wrd_bits] & (1 << (i % wrd_bits))));
+		free((char *) set2);
+		expp->nd_symb = INTEGER;
+	}
+	else {
+		set1 = expp->nd_left->nd_set;
+		resultset = set1;
+		expp->nd_left->nd_set = 0;
+		switch(expp->nd_symb) {
+		case '+':
+			/* Set union
+			*/
+			for (j = 0; j < setsize; j++) {
+				*set1++ |= *set2++;
+			}
+			break;
+
+		case '-':
+			/* Set difference
+			*/
+			for (j = 0; j < setsize; j++) {
+				*set1++ &= ~*set2++;
+			}
+			break;
+
+		case '*':
+			/* Set intersection
+			*/
+			for (j = 0; j < setsize; j++) {
+				*set1++ &= *set2++;
+			}
+			break;
+
+		case '/':
+			/* Symmetric set difference
+			*/
+			for (j = 0; j < setsize; j++) {
+				*set1++ ^= *set2++;
+			}
+			break;
+
+		case GREATEREQUAL:
+		case LESSEQUAL:
+		case '=':
+		case '#':
+			/* Constant set comparisons
+			*/
+			expp->nd_left->nd_set = set1;	/* may be disposed of */
+			for (j = 0; j < setsize; j++) {
+				switch(expp->nd_symb) {
+				case GREATEREQUAL:
+					if ((*set1 | *set2++) != *set1) break;
+					set1++;
+					continue;
+				case LESSEQUAL:
+					if ((*set2 | *set1++) != *set2) break;
+					set2++;
+					continue;
+				case '=':
+				case '#':
+					if (*set1++ != *set2++) break;
+					continue;
+				}
+				break;
+			}
+			if (j < setsize) {
+				expp->nd_INT = expp->nd_symb == '#';
+			}
+			else {
+				expp->nd_INT = expp->nd_symb != '#';
+			}
+			expp->nd_class = Value;
+			expp->nd_symb = INTEGER;
+			freesets(expp);
+			return;
+		default:
+			crash("(cstset)");
+		}
+		freesets(expp);
+		expp->nd_class = Set;
+		expp->nd_set = resultset;
+		return;
+	}
+	FreeNode(expp->nd_left);
+	FreeNode(expp->nd_right);
+	expp->nd_left = expp->nd_right = 0;
+}
+
+freesets(expp)
+	register struct node *expp;
+{
+	if (expp->nd_right->nd_set) {
+		free((char *) expp->nd_right->nd_set);
+	}
+	if (expp->nd_left->nd_set) {
+		free((char *) expp->nd_left->nd_set);
+	}
+	FreeNode(expp->nd_left);
+	FreeNode(expp->nd_right);
+	expp->nd_left = expp->nd_right = 0;
+}
+
+cstcall(expp, call)
+	register struct node *expp;
+{
+	/*	a standard procedure call is found that can be evaluated
+		compile time, so do so.
+	*/
+	register struct node *expr = 0;
+
+	assert(expp->nd_class == Call);
+
+	if (expp->nd_right) {
+		expr = expp->nd_right->nd_left;
+		expp->nd_right->nd_left = 0;
+		FreeNode(expp->nd_right);
+	}
+
+	expp->nd_class = Value;
+	expp->nd_symb = INTEGER;
+	switch(call) {
+	case S_ABS:
+		if (expr->nd_INT < 0) expp->nd_INT = - expr->nd_INT;
+		else expp->nd_INT = expr->nd_INT;
+		CutSize(expp);
+		break;
+
+	case S_CAP:
+		if (expr->nd_INT >= 'a' && expr->nd_INT <= 'z') {
+			expr->nd_INT = expr->nd_INT + ('A' - 'a');
+		}
+		expp->nd_INT = expr->nd_INT;
+		break;
+
+	case S_MAX:
+		if (expp->nd_type == int_type) {
+			expp->nd_INT = max_int;
+		}
+		else if (expp->nd_type == longint_type) {
+			expp->nd_INT = max_longint;
+		}
+		else if (expp->nd_type == card_type) {
+			expp->nd_INT = max_unsigned;
+		}
+		else if (expp->nd_type->tp_fund == T_SUBRANGE) {
+			expp->nd_INT = expp->nd_type->sub_ub;
+		}
+		else	expp->nd_INT = expp->nd_type->enm_ncst - 1;
+		break;
+
+	case S_MIN:
+		if (expp->nd_type == int_type) {
+			expp->nd_INT = -max_int;
+			if (! options['s']) expp->nd_INT--;
+		}
+		else if (expp->nd_type == longint_type) {
+			expp->nd_INT = - max_longint;
+			if (! options['s']) expp->nd_INT--;
+		}
+		else if (expp->nd_type->tp_fund == T_SUBRANGE) {
+			expp->nd_INT = expp->nd_type->sub_lb;
+		}
+		else	expp->nd_INT = 0;
+		break;
+
+	case S_ODD:
+		expp->nd_INT = (expr->nd_INT & 1);
+		break;
+
+	case S_SIZE:
+		expp->nd_INT = expr->nd_type->tp_size;
+		break;
+
+	default:
+		crash("(cstcall)");
+	}
+	FreeNode(expr);
+	FreeNode(expp->nd_left);
+	expp->nd_right = expp->nd_left = 0;
+}
+
+CutSize(expr)
+	register struct node *expr;
+{
+	/*	The constant value of the expression expr is made to
+		conform to the size of the type of the expression.
+	*/
+	register arith o1 = expr->nd_INT;
+	register struct type *tp = BaseType(expr->nd_type);
+	int uns;
+	int size = tp->tp_size;
+
+	assert(expr->nd_class == Value);
+	uns = (tp->tp_fund & (T_CARDINAL|T_CHAR));
+	if (uns) {
+		if (o1 & ~full_mask[size]) {
+			node_warning(expr, W_ORDINARY, ovflow);
+			o1 &= full_mask[size];
+		}
+	}
+	else {
+		int nbits = (int) (mach_long_size - size) * 8;
+		long remainder = o1 & ~int_mask[size];
+
+		if (remainder != 0 && remainder != ~int_mask[size]) {
+			node_warning(expr, W_ORDINARY, ovflow);
+			o1 <<= nbits;
+			o1 >>= nbits;
+		}
+	}
+	expr->nd_INT = o1;
+}
+
+InitCst()
+{
+	register int i = 0;
+	register 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;
+		int_mask[i] = bt & ~(1L << ((i << 3) - 1));
+	}
+	mach_long_size = i;
+	mach_long_sign = 1L << (mach_long_size * 8 - 1);
+	if (long_size > mach_long_size) {
+		fatal("sizeof (long) insufficient on this machine");
+	}
+
+	max_int = int_mask[int_size];
+	max_unsigned = full_mask[int_size];
+	max_longint = int_mask[long_size];
+	wrd_bits = 8 * (unsigned) word_size;
+}

lang/m2/comp/debug.h

@@ -0,0 +1,18 @@
+/*
+ * (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
+ */
+
+/* D E B U G G I N G   M A C R O */
+
+/* $Header$ */
+
+#include "debugcst.h"
+
+#ifdef DEBUG
+#define DO_DEBUG(x, y)	((x) && (y))
+#else
+#define DO_DEBUG(x, y)
+#endif

lang/m2/comp/declar.g

@@ -0,0 +1,529 @@
+/*
+ * (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
+ */
+
+/* D E C L A R A T I O N S */
+
+/* $Header$ */
+
+{
+#include	"debug.h"
+
+#include	<em_arith.h>
+#include	<em_label.h>
+#include	<alloc.h>
+#include	<assert.h>
+
+#include	"idf.h"
+#include	"LLlex.h"
+#include	"def.h"
+#include	"type.h"
+#include	"scope.h"
+#include	"node.h"
+#include	"misc.h"
+#include	"main.h"
+#include	"chk_expr.h"
+#include	"warning.h"
+
+int		proclevel = 0;		/* nesting level of procedures */
+int		return_occurred;	/* set if a return occurs in a block */
+
+#define needs_static_link()	(proclevel > 1)
+extern struct node *EmptyStatement;
+}
+
+/* inline in declaration: need space
+ProcedureDeclaration
+{
+	struct def *df;
+} :
+			{	++proclevel; }
+	ProcedureHeading(&df, D_PROCEDURE)
+	';' block(&(df->prc_body))
+	IDENT
+			{	EndProc(df, dot.TOK_IDF);
+				--proclevel;
+			}
+;
+*/
+
+ProcedureHeading(struct def **pdf; int type;)
+{
+	struct type *tp = 0;
+	arith parmaddr = needs_static_link() ? pointer_size : 0;
+	struct paramlist *pr = 0;
+} :
+	PROCEDURE IDENT
+			{ *pdf = DeclProc(type, dot.TOK_IDF); }
+	[
+		'('
+		[
+			FPSection(&pr, &parmaddr)
+			[
+				';' FPSection(&pr, &parmaddr)
+			]*
+		]?
+		')'
+		[	':' qualtype(&tp)
+		]?
+	]?
+			{ CheckWithDef(*pdf, proc_type(tp, pr, parmaddr));
+			  if (tp && IsConstructed(tp)) {
+warning(W_STRICT, "procedure \"%s\" has a constructed result type",
+	(*pdf)->df_idf->id_text);
+			  }
+			}
+;
+
+block(struct node **pnd;) :
+	[	%persistent
+		declaration
+	]*
+			{ return_occurred = 0; }
+	[	%default
+		BEGIN
+		StatementSequence(pnd)
+	|
+			{ *pnd = EmptyStatement; }
+	]
+	END
+;
+
+declaration
+{
+	struct def *df;
+} :
+	CONST [ ConstantDeclaration ';' ]*
+|
+	TYPE [ TypeDeclaration ';' ]*
+|
+	VAR [ VariableDeclaration ';' ]*
+|
+			{	++proclevel; }
+	ProcedureHeading(&df, D_PROCEDURE)
+	';'
+	block(&(df->prc_body))
+	IDENT
+			{	EndProc(df, dot.TOK_IDF);
+				--proclevel;
+			}
+	';'
+|
+	ModuleDeclaration ';'
+;
+
+/* inline in procedureheading: need space
+FormalParameters(struct paramlist **ppr; arith *parmaddr; struct type **ptp;):
+	'('
+	[
+		FPSection(ppr, parmaddr)
+		[
+			';' FPSection(ppr, parmaddr)
+		]*
+	]?
+	')'
+	[	':' qualtype(ptp)
+	]?
+;
+*/
+
+FPSection(struct paramlist **ppr; arith *parmaddr;)
+{
+	struct node *FPList;
+	struct type *tp;
+	int VARp;
+} :
+	var(&VARp) IdentList(&FPList) ':' FormalType(&tp)
+			{ EnterParamList(ppr, FPList, tp, VARp, parmaddr); }
+;
+
+FormalType(struct type **ptp;)
+{
+	extern arith ArrayElSize();
+} :
+	ARRAY OF qualtype(ptp)
+		{ /* index type of conformant array is "CARDINAL".
+		     Recognize a conformant array by size 0.
+		  */
+		  register struct type *tp = construct_type(T_ARRAY, card_type);
+
+		  tp->arr_elem = *ptp;
+		  *ptp = tp;
+		  tp->arr_elsize = ArrayElSize(tp->arr_elem);
+		  tp->tp_align = tp->arr_elem->tp_align;
+		}
+|
+	 qualtype(ptp)
+;
+
+TypeDeclaration
+{
+	struct def *df;
+	struct type *tp;
+	register struct node *nd;
+}:
+	IDENT		{ df = define(dot.TOK_IDF, CurrentScope, D_TYPE);
+			  nd = dot2leaf(Name);
+			}
+	'=' type(&tp)
+			{ DeclareType(nd, df, tp);
+			  free_node(nd);
+			}
+;
+
+type(register struct type **ptp;):
+	%default SimpleType(ptp)
+|
+	ArrayType(ptp)
+|
+	RecordType(ptp)
+|
+	SetType(ptp)
+|
+	PointerType(ptp)
+|
+	ProcedureType(ptp)
+;
+
+SimpleType(register struct type **ptp;)
+{
+	struct type *tp;
+} :
+	qualtype(ptp)
+	[
+		/* nothing */
+	|
+		SubrangeType(&tp)
+		/* The subrange type is given a base type by the
+		   qualident (this is new modula-2).
+		*/
+			{ chk_basesubrange(tp, *ptp); *ptp = tp; }
+	]
+|
+	enumeration(ptp)
+|
+	SubrangeType(ptp)
+;
+
+enumeration(struct type **ptp;)
+{
+	struct node *EnumList;
+} :
+	'(' IdentList(&EnumList) ')'
+		{ *ptp = enum_type(EnumList); }
+;
+
+IdentList(struct node **p;)
+{
+	register struct node *q;
+} :
+	IDENT		{ *p = q = dot2leaf(Value); }
+	[ %persistent
+		',' IDENT
+			{ q->nd_left = dot2leaf(Value);
+			  q = q->nd_left;
+			}
+	]*
+			{ q->nd_left = 0; }
+;
+
+SubrangeType(struct type **ptp;)
+{
+	struct node *nd1, *nd2;
+}:
+	/*
+	   This is not exactly the rule in the new report, but see
+	   the rule for "SimpleType".
+	*/
+	'[' ConstExpression(&nd1)
+	UPTO ConstExpression(&nd2)
+	']'
+			{ *ptp = subr_type(nd1, nd2);
+			  free_node(nd1);
+			  free_node(nd2);
+			}
+;
+
+ArrayType(struct type **ptp;)
+{
+	struct type *tp;
+	register struct type *tp2;
+} :
+	ARRAY SimpleType(&tp)
+			{ *ptp = tp2 = construct_type(T_ARRAY, tp); }
+	[
+		',' SimpleType(&tp)
+			{ tp2->arr_elem = construct_type(T_ARRAY, tp);
+			  tp2 = tp2->arr_elem;
+			}
+	]* OF type(&tp)
+			{ tp2->arr_elem = tp;
+			  ArraySizes(*ptp);
+			}
+;
+
+RecordType(struct type **ptp;)
+{
+	register struct scope *scope;
+	arith size = 0;
+	int xalign = struct_align;
+}
+:
+	RECORD
+		{ scope = open_and_close_scope(OPENSCOPE); }
+	FieldListSequence(scope, &size, &xalign)
+		{ if (size == 0) {
+			warning(W_ORDINARY, "empty record declaration");
+			size = 1;
+		  }
+		  *ptp = standard_type(T_RECORD, xalign, size);
+		  (*ptp)->rec_scope = scope;
+		}
+	END
+;
+
+FieldListSequence(struct scope *scope; arith *cnt; int *palign;):
+	FieldList(scope, cnt, palign)
+	[
+		';' FieldList(scope, cnt, palign)
+	]*
+;
+
+FieldList(struct scope *scope; arith *cnt; int *palign;)
+{
+	struct node *FldList;
+	struct type *tp;
+	struct node *nd;
+	register struct def *df;
+	arith tcnt, max;
+} :
+[
+	IdentList(&FldList) ':' type(&tp)
+			{
+			  *palign = lcm(*palign, tp->tp_align);
+			  EnterFieldList(FldList, tp, scope, cnt);
+			}
+|
+	CASE
+	/* Also accept old fashioned Modula-2 syntax, but give a warning.
+	   Sorry for the complicated code.
+	*/
+	[ qualident(&nd)
+	  [ ':' qualtype(&tp)
+			/* This is correct, in both kinds of Modula-2, if
+		   	   the first qualident is a single identifier.
+			*/
+			{ if (nd->nd_class != Name) {
+				error("illegal variant tag");
+		  	  }
+			  else {
+			  	df = define(nd->nd_IDF, scope, D_FIELD);
+			  	*palign = lcm(*palign, tp->tp_align);
+			  	if (!(tp->tp_fund & T_DISCRETE)) {
+					error("illegal type in variant");
+			  	}
+			  	df->df_type = tp;
+			  	df->fld_off = align(*cnt, tp->tp_align);
+			  	*cnt = df->fld_off + tp->tp_size;
+			  	df->df_flags |= D_QEXPORTED;
+			  }
+			  FreeNode(nd);
+			}
+	  |		/* Old fashioned! the first qualident now represents
+			   the type
+			*/
+			{ warning(W_OLDFASHIONED,
+			      "old fashioned Modula-2 syntax; ':' missing");
+			  tp = qualified_type(nd);
+			}
+	  ]
+	| ':' qualtype(&tp)
+	  /* Aha, third edition. Well done! */
+	]
+			{ tcnt = *cnt; }
+	OF variant(scope, &tcnt, tp, palign)
+			{ max = tcnt; tcnt = *cnt; }
+	[
+	  '|' variant(scope, &tcnt, tp, palign)
+			{ if (tcnt > max) max = tcnt; tcnt = *cnt; }
+	]*
+	[ ELSE FieldListSequence(scope, &tcnt, palign)
+			{ if (tcnt > max) max = tcnt; }
+	]?
+	END
+			{ *cnt = max; }
+]?
+;
+
+variant(struct scope *scope; arith *cnt; struct type *tp; int *palign;)
+{
+	struct node *nd;
+} :
+	[
+		CaseLabelList(&tp, &nd)
+			{ /* Ignore the cases for the time being.
+			     Maybe a checking version will be supplied
+			     later ???
+			  */
+			  FreeNode(nd);
+			}
+		':' FieldListSequence(scope, cnt, palign)
+	]?
+			/* Changed rule in new modula-2 */
+;
+
+CaseLabelList(struct type **ptp; struct node **pnd;):
+	CaseLabels(ptp, pnd)
+	[	
+			{ *pnd = dot2node(Link, *pnd, NULLNODE); }
+		',' CaseLabels(ptp, &((*pnd)->nd_right))
+			{ pnd = &((*pnd)->nd_right); }
+	]*
+;
+
+CaseLabels(struct type **ptp; register struct node **pnd;)
+{
+	register struct node *nd;
+}:
+	ConstExpression(pnd)
+			{ 
+			  if (*ptp != 0) {
+				ChkCompat(pnd, *ptp, "case label");
+			  }
+			  nd = *pnd;
+			}
+	[
+		UPTO	{ *pnd = dot2node(Link,nd,NULLNODE); }
+		ConstExpression(&(*pnd)->nd_right)
+			{ if (!ChkCompat(&((*pnd)->nd_right), nd->nd_type,
+					 "case label")) {
+			  	nd->nd_type = error_type;
+			  }
+			}
+	]?
+			{
+			  *ptp = nd->nd_type;
+			}
+;
+
+SetType(struct type **ptp;) :
+	SET OF SimpleType(ptp)
+			{ *ptp = set_type(*ptp); }
+;
+
+/*	In a pointer type definition, the type pointed at does not
+	have to be declared yet, so be careful about identifying
+	type-identifiers
+*/
+PointerType(register struct type **ptp;) :
+			{ *ptp = construct_type(T_POINTER, NULLTYPE); }
+	POINTER TO
+	[ %if	(type_or_forward(ptp))
+	  type(&((*ptp)->tp_next)) 
+	|
+	  IDENT
+	]
+;
+
+qualtype(struct type **ptp;)
+{
+	struct node *nd;
+} :
+	qualident(&nd)
+		{ *ptp = qualified_type(nd); }
+;
+
+ProcedureType(struct type **ptp;) :
+	PROCEDURE 
+	[
+	  	FormalTypeList(ptp)
+	|
+			{ *ptp = proc_type((struct type *) 0, 
+					   (struct paramlist *) 0,
+					   (arith) 0);
+			}
+	]
+;
+
+FormalTypeList(struct type **ptp;)
+{
+	struct paramlist *pr = 0;
+	arith parmaddr = 0;
+} :
+	'('
+	[
+		VarFormalType(&pr, &parmaddr)
+		[
+			',' VarFormalType(&pr, &parmaddr)
+		]*
+	]?
+	')'
+	[ ':' qualtype(ptp)
+	|		{ *ptp = 0; }
+	]
+			{ *ptp = proc_type(*ptp, pr, parmaddr); }
+;
+
+VarFormalType(struct paramlist **ppr; arith *parmaddr;)
+{
+	struct type *tp;
+	int isvar;
+} :
+	var(&isvar)
+	FormalType(&tp)
+			{ EnterParamList(ppr,NULLNODE,tp,isvar,parmaddr); }
+;
+
+var(int *VARp;) :
+	[
+		VAR		{ *VARp = D_VARPAR; }
+	|
+		/* empty */	{ *VARp = D_VALPAR; }
+	]
+;
+
+ConstantDeclaration
+{
+	struct idf *id;
+	struct node *nd;
+	register struct def *df;
+}:
+	IDENT		{ id = dot.TOK_IDF; }
+	'=' ConstExpression(&nd)
+			{ df = define(id,CurrentScope,D_CONST);
+			  df->con_const = nd->nd_token;
+			  df->df_type = nd->nd_type;
+			  FreeNode(nd);
+			}
+;
+
+VariableDeclaration
+{
+	struct node *VarList;
+	register struct node *nd;
+	struct type *tp;
+} :
+	IdentAddr(&VarList)
+			{ nd = VarList; }
+	[ %persistent
+		',' IdentAddr(&(nd->nd_right))
+			{ nd = nd->nd_right; }
+	]*
+	':' type(&tp)
+			{ EnterVarList(VarList, tp, proclevel > 0); }
+;
+
+IdentAddr(struct node **pnd;) 
+{
+	register struct node *nd;
+} :
+	IDENT		{ nd = dot2leaf(Name); }
+	[	'['
+		ConstExpression(&(nd->nd_left))
+		']'
+	]?
+			{ *pnd = nd; }
+;

lang/m2/comp/def.H

@@ -0,0 +1,142 @@
+/*
+ * (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
+ */
+
+/* I D E N T I F I E R   D E S C R I P T O R   S T R U C T U R E */
+
+/* $Header$ */
+
+struct module {
+	struct node *mo_priority;/* priority of a module */
+	struct scopelist *mo_vis;/* scope of this module */
+	struct node *mo_body;	/* body of this module */
+#define mod_priority	df_value.df_module.mo_priority
+#define mod_vis		df_value.df_module.mo_vis
+#define mod_body	df_value.df_module.mo_body
+};
+
+struct variable {
+	arith va_off;		/* address or offset of variable */
+	char *va_name;		/* name of variable if given */
+#define var_off		df_value.df_variable.va_off
+#define var_name	df_value.df_variable.va_name
+};
+
+struct constant {
+	struct token co_const;	/* result of a constant expression */
+#define con_const	df_value.df_constant.co_const
+};
+
+struct enumval {
+	arith en_val;	/* value of this enumeration literal */
+	struct def *en_next;	/* next enumeration literal */
+#define enm_val		df_value.df_enum.en_val
+#define enm_next	df_value.df_enum.en_next
+};
+
+struct field {
+	arith fd_off;
+	struct variant {
+		struct caselabellist *v_cases;
+		label v_casedescr;
+		struct def *v_varianttag;
+	} *fd_variant;
+#define fld_off		df_value.df_field.fd_off
+#define fld_variant	df_value.df_field.fd_variant
+};
+
+struct dfproc {
+	struct scopelist *pr_vis; /* scope of procedure */
+	struct node *pr_body;	/* body of this procedure */
+#define prc_vis		df_value.df_proc.pr_vis
+#define prc_body	df_value.df_proc.pr_body
+};
+
+struct import {
+	struct def *im_def;	/* imported definition */
+#define imp_def		df_value.df_import.im_def
+};
+
+struct dforward {
+	struct scopelist *fo_vis;
+	struct node *fo_node;
+	char *fo_name;
+#define for_node	df_value.df_forward.fo_node
+#define for_vis		df_value.df_forward.fo_vis
+#define for_name	df_value.df_forward.fo_name
+};
+
+struct forwtype {
+	struct node *f_node;
+#define df_forw_node	df_value.df_fortype.f_node
+};
+
+struct def	{		/* list of definitions for a name */
+	struct def *df_next;	/* next definition in definitions chain */
+	struct def *df_nextinscope;
+				/* link all definitions in a scope */
+	struct idf *df_idf;	/* link back to the name */
+	struct scope *df_scope;	/* scope in which this definition resides */
+	unsigned short df_kind;	/* the kind of this definition: */
+#define D_MODULE	0x0001	/* a module */
+#define D_PROCEDURE	0x0002	/* procedure of function */
+#define D_VARIABLE	0x0004	/* a variable */
+#define D_FIELD		0x0008	/* a field in a record */
+#define D_TYPE		0x0010	/* a type */
+#define D_ENUM		0x0020	/* an enumeration literal */
+#define D_CONST		0x0040	/* a constant */
+#define D_IMPORT	0x0080	/* an imported definition */
+#define D_PROCHEAD	0x0100	/* a procedure heading in a definition module */
+#define D_HIDDEN	0x0200	/* a hidden type */
+#define D_FORWARD	0x0400	/* not yet defined */
+#define D_FORWMODULE	0x0800	/* module must be declared later */
+#define D_FORWTYPE	0x1000	/* forward type */
+#define D_FTYPE		0x2000	/* resolved forward type */
+#define D_ERROR		0x4000	/* a compiler generated definition for an
+				   undefined variable
+				*/
+#define D_VALUE	(D_PROCEDURE|D_VARIABLE|D_FIELD|D_ENUM|D_CONST|D_PROCHEAD)
+#define D_ISTYPE	(D_HIDDEN|D_TYPE|D_FTYPE)
+#define is_type(dfx)	((dfx)->df_kind & D_ISTYPE)
+	unsigned short  df_flags;
+#define D_NOREG		0x01	/* set if it may not reside in a register */
+#define D_USED		0x02	/* set if used (future use ???) */
+#define D_DEFINED	0x04	/* set if it is assigned a value (future use ???) */
+#define D_VARPAR	0x08	/* set if it is a VAR parameter */
+#define D_VALPAR	0x10	/* set if it is a value parameter */
+#define D_EXPORTED	0x20	/* set if exported */
+#define D_QEXPORTED	0x40	/* set if qualified exported */
+#define D_BUSY		0x80	/* set if busy reading this definition module */
+#define D_FOREIGN	0x100	/* set for foreign language modules */
+#define D_ADDRGIVEN	0x200	/* set if address given for variable */
+#define D_FORLOOP	0x400	/* set if busy in for-loop */
+	struct type *df_type;
+	union {
+		struct module df_module;
+		struct variable df_variable;
+		struct constant df_constant;
+		struct enumval df_enum;
+		struct field df_field;
+		struct import df_import;
+		struct dfproc df_proc;
+		struct dforward df_forward;
+		struct forwtype df_fortype;
+		int df_stdname;	/* define for standard name */
+	} df_value;
+};
+
+/* ALLOCDEF "def" 50 */
+
+extern struct def
+	*define(),
+	*DefineLocalModule(),
+	*MkDef(),
+	*DeclProc();
+
+extern struct def
+	*lookup(),
+	*lookfor();
+#define NULLDEF ((struct def *) 0)

lang/m2/comp/def.c

@@ -0,0 +1,381 @@
+/*
+ * (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
+ */
+
+/* D E F I N I T I O N   M E C H A N I S M */
+
+/* $Header$ */
+
+#include	"debug.h"
+
+#include	<alloc.h>
+#include	<em_arith.h>
+#include	<em_label.h>
+#include	<assert.h>
+
+#include	"LLlex.h"
+#include	"main.h"
+#include	"def.h"
+#include	"type.h"
+#include	"idf.h"
+#include	"scope.h"
+#include	"node.h"
+#include	"Lpars.h"
+
+STATIC
+DefInFront(df)
+	register struct def *df;
+{
+	/*	Put definition "df" in front of the list of definitions
+		in its scope.
+		This is neccessary because in some cases the order in this
+		list is important.
+	*/
+	register struct def *df1 = df->df_scope->sc_def;
+
+	if (df1 != df) {
+		/* Definition "df" is not in front of the list
+		*/
+		while (df1) {
+			/* Find definition "df"
+			*/
+			if (df1->df_nextinscope == df) {
+				/* It already was in the list. Remove it
+				*/
+				df1->df_nextinscope = df->df_nextinscope;
+				break;
+			}
+			df1 = df1->df_nextinscope;
+		}
+
+		/* Now put it in front
+		*/
+		df->df_nextinscope = df->df_scope->sc_def;
+		df->df_scope->sc_def = df;
+	}
+}
+
+struct def *
+MkDef(id, scope, kind)
+	register struct idf *id;
+	register 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_idf = id;
+	df->df_scope = scope;
+	df->df_kind = kind;
+	df->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;
+	register struct scope *scope;
+	int kind;
+{
+	/*	Declare an identifier in a scope, but first check if it
+		already has been defined.
+		If so, then check for the cases in which this is legal,
+		and otherwise give an error message.
+	*/
+	register struct def *df;
+
+	df = lookup(id, scope, 1);
+	if (	/* Already in this scope */
+		df
+	   ||	/* A closed scope, and id defined in the pervasive scope */
+		( 
+		  scopeclosed(scope)
+		&&
+		  (df = lookup(id, PervasiveScope, 1)))
+	   ) {
+		switch(df->df_kind) {
+		case D_HIDDEN:
+			/* An opaque type. We may now have found the
+			   definition of this type.
+			*/
+			if (kind == D_TYPE && !DefinitionModule) {
+				df->df_kind = D_TYPE;
+				return df;
+			}
+			break;
+
+		case D_FORWMODULE:
+			/* A forward reference to a module. We may have found
+			   another one, or we may have found the definition
+			   for this module.
+			*/
+			if (kind == D_FORWMODULE) {
+				return df;
+			}
+
+			if (kind == D_MODULE) {
+				FreeNode(df->for_node);
+				df->mod_vis = df->for_vis;
+				df->df_kind = kind;
+				DefInFront(df);
+				return df;
+			}
+			break;
+
+		case D_TYPE:
+			if (kind == D_FORWTYPE) return df;
+			break;
+		case D_FORWTYPE:
+			if (kind == D_FORWTYPE) return df;
+			if (kind == D_TYPE) {
+				df->df_kind = D_FTYPE;
+			}
+			else {
+				error("identifier \"%s\" must be a type",
+					id->id_text);
+			}
+			return df;
+
+		case D_FORWARD:
+			/* A forward reference, for which we may now have
+			   found a definition.
+			*/
+			if (kind != D_FORWARD) {
+				FreeNode(df->for_node);
+			}
+
+			/* Fall through */
+
+		case D_ERROR:
+			/* A definition generated by the compiler, because
+			   it found an error. Maybe, the user gives a
+			   definition after all.
+			*/
+			df->df_kind = kind;
+			return df;
+		}
+
+		if (kind != D_ERROR) {
+			/* Avoid spurious error messages
+			*/
+			error("identifier \"%s\" already declared",
+			      id->id_text);
+		}
+
+		return df;
+	}
+
+	return MkDef(id, scope, kind);
+}
+
+RemoveImports(pdf)
+	register struct def **pdf;
+{
+	/*	Remove all imports from a definition module. This is
+		neccesary because the implementation module might import
+		them again.
+	*/
+	register struct def *df = *pdf;
+
+	while (df) {
+		if (df->df_kind == D_IMPORT) {
+			RemoveFromIdList(df);
+			*pdf = df->df_nextinscope;
+			free_def(df);
+		}
+		else {
+			pdf = &(df->df_nextinscope);
+		}
+		df = *pdf;
+	}
+}
+
+RemoveFromIdList(df)
+	register struct def *df;
+{
+	/*	Remove definition "df" from the definition list
+	*/
+	register struct idf *id = df->df_idf;
+	register struct def *df1;
+
+	if ((df1 = id->id_def) == df) id->id_def = df->df_next;
+	else {
+		while (df1->df_next != df) {
+			assert(df1->df_next != 0);
+			df1 = df1->df_next;
+		}
+		df1->df_next = df->df_next;
+	}
+}
+
+struct def *
+DeclProc(type, id)
+	register struct idf *id;
+{
+	/*	A procedure is declared, either in a definition or a program
+		module. Create a def structure for it (if neccessary).
+		Also create a name for it.
+	*/
+	register struct def *df;
+	register struct scope *scope;
+	extern char *sprint();
+	static int nmcount;
+	char buf[256];
+
+	assert(type & (D_PROCEDURE | D_PROCHEAD));
+
+	if (type == D_PROCHEAD) {
+		/* In a definition module
+		*/
+		df = define(id, CurrentScope, type);
+		df->for_node = dot2leaf(Name);
+		if (CurrentScope->sc_definedby->df_flags & D_FOREIGN) {
+			df->for_name = id->id_text;
+		}
+		else {
+			sprint(buf,"%s_%s",CurrentScope->sc_name,id->id_text);
+			df->for_name = Salloc(buf, (unsigned) (strlen(buf)+1));
+		}
+		if (CurrVis == Defined->mod_vis) {
+			/* The current module will define this routine.
+			   make sure the name is exported.
+			*/
+			C_exp(df->for_name);
+		}
+	}
+	else {
+		char *name;
+
+		df = lookup(id, CurrentScope, 1);
+		if (df && df->df_kind == D_PROCHEAD) {
+			/* C_exp already generated when we saw the definition
+			   in the definition module
+			*/
+			df->df_kind = D_PROCEDURE;
+			name = df->for_name;
+			DefInFront(df);
+		}
+		else {
+			df = define(id, CurrentScope, type);
+			sprint(buf,"_%d_%s",++nmcount,id->id_text);
+			name = Salloc(buf, (unsigned)(strlen(buf)+1));
+			if (options['x']) {
+				C_exp(buf);
+			}
+			else	C_inp(buf);
+		}
+		open_scope(OPENSCOPE);
+		scope = CurrentScope;
+		scope->sc_name = name;
+		scope->sc_definedby = df;
+	}
+	df->prc_vis = CurrVis;
+
+	return df;
+}
+
+EndProc(df, id)
+	register struct def *df;
+	struct idf *id;
+{
+	/*	The end of a procedure declaration.
+		Check that the closing identifier matches the name of the
+		procedure, close the scope, and check that a function
+		procedure has at least one RETURN statement.
+	*/
+	extern int return_occurred;
+
+	match_id(id, df->df_idf);
+	close_scope(SC_CHKFORW|SC_REVERSE);
+	if (! return_occurred && ResultType(df->df_type)) {
+		error("function procedure %s does not return a value",
+		      df->df_idf->id_text);
+	}
+}
+
+struct def *
+DefineLocalModule(id)
+	struct idf *id;
+{
+	/*	Create a definition for a local module. Also give it
+		a name to be used for code generation.
+	*/
+	register struct def *df = define(id, CurrentScope, D_MODULE);
+	register struct scope *sc;
+	static int modulecount = 0;
+	char buf[256];
+	extern char *sprint();
+	extern int proclevel;
+
+	sprint(buf, "_%d%s", ++modulecount, id->id_text);
+
+	if (!df->mod_vis) {	
+		/* We never saw the name of this module before. Create a
+		   scope for it.
+		*/
+	  	open_scope(CLOSEDSCOPE);
+	  	df->mod_vis = CurrVis;
+	}
+
+	CurrVis = df->mod_vis;
+
+	sc = CurrentScope;
+	sc->sc_level = proclevel;
+	sc->sc_definedby = df;
+	sc->sc_name = Salloc(buf, (unsigned) (strlen(buf) + 1));
+
+	/* Create a type for it
+	*/
+	df->df_type = standard_type(T_RECORD, 1, (arith) 0);
+	df->df_type->rec_scope = sc;
+
+	/* Generate code that indicates that the initialization procedure
+	   for this module is local.
+	*/
+	if (options['x']) {
+		C_exp(buf);
+	}
+	else	C_inp(buf);
+
+	return df;
+}
+
+CheckWithDef(df, tp)
+	register struct def *df;
+	struct type *tp;
+{
+	/*	Check the header of a procedure declaration against a
+		possible earlier definition in the definition module.
+	*/
+
+	if (df->df_type) {
+		/* We already saw a definition of this type
+		   in the definition module.
+		*/
+	  	if (!TstProcEquiv(tp, df->df_type)) {
+			error("inconsistent procedure declaration for \"%s\"",
+			      df->df_idf->id_text); 
+		}
+		FreeType(df->df_type);
+	}
+	df->df_type = tp;
+}
+
+#ifdef DEBUG
+PrDef(df)
+	register struct def *df;
+{
+	print("n: %s, k: %d\n", df->df_idf->id_text, df->df_kind);
+}
+#endif DEBUG

lang/m2/comp/def_sizes.h

@@ -0,0 +1,22 @@
+/* D E F A U L T   S I Z E S   A N D   A L I G N M E N T S */
+
+/* $Header$ */
+
+#define MAXSIZE		8	/* the maximum of the SZ_* constants	*/
+/* target machine sizes	*/
+#define	SZ_CHAR		(arith)1
+#define SZ_WORD		(arith)4
+#define	SZ_INT		(arith)4
+#define	SZ_LONG		(arith)4
+#define	SZ_FLOAT	(arith)4
+#define	SZ_DOUBLE	(arith)8
+#define	SZ_POINTER	(arith)4
+/* target machine alignment requirements	*/
+#define	AL_CHAR		1
+#define AL_WORD		(int) SZ_WORD
+#define	AL_INT		(int) SZ_WORD
+#define	AL_LONG		(int) SZ_WORD
+#define	AL_FLOAT	(int) SZ_WORD
+#define	AL_DOUBLE	(int) SZ_WORD
+#define	AL_POINTER	(int) SZ_WORD
+#define AL_STRUCT	1

lang/m2/comp/defmodule.c

@@ -0,0 +1,166 @@
+/*
+ * (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
+ */
+
+/* D E F I N I T I O N   M O D U L E S */
+
+/* $Header$ */
+
+#include	"debug.h"
+
+#include	<assert.h>
+#include	<em_arith.h>
+#include	<em_label.h>
+#include	<alloc.h>
+
+#include	"idf.h"
+#include	"input.h"
+#include	"scope.h"
+#include	"LLlex.h"
+#include	"def.h"
+#include	"Lpars.h"
+#include	"f_info.h"
+#include	"main.h"
+#include	"node.h"
+#include	"type.h"
+#include	"misc.h"
+
+#ifdef DEBUG
+long	sys_filesize();
+#endif
+
+struct idf *DefId;
+
+char *
+getwdir(fn)
+	register char *fn;
+{
+	register char *p;
+	char *strrindex();
+
+	p = strrindex(fn, '/');
+	while (p && *(p + 1) == '\0') {	/* remove trailing /'s */
+		*p = '\0';
+		p = strrindex(fn, '/');
+	}
+
+	if (p) {
+		*p = '\0';
+		fn = Salloc(fn, (unsigned) (p - &fn[0] + 1));
+		*p = '/';
+		return fn;
+	}
+	else return ".";
+}
+
+STATIC
+GetFile(name)
+	char *name;
+{
+	/*	Try to find a file with basename "name" and extension ".def",
+		in the directories mentioned in "DEFPATH".
+	*/
+	char buf[15];
+	char *strncpy(), *strcat();
+
+	strncpy(buf, name, 10);
+	buf[10] = '\0';			/* maximum length */
+	strcat(buf, ".def");
+	DEFPATH[0] = WorkingDir;
+	if (! InsertFile(buf, DEFPATH, &(FileName))) {
+		error("could not find a DEFINITION MODULE for \"%s\"", name);
+		return 0;
+	}
+	WorkingDir = getwdir(FileName);
+	LineNumber = 1;
+	DO_DEBUG(options['F'], debug("File %s : %ld characters", FileName, sys_filesize(FileName)));
+	return 1;
+}
+
+struct def *
+GetDefinitionModule(id, incr)
+	register struct idf *id;
+{
+	/*	Return a pointer to the "def" structure of the definition
+		module indicated by "id".
+		We may have to read the definition module itself.
+		Also increment level by "incr".
+	*/
+	register struct def *df;
+	static int level;
+	struct scopelist *vis;
+	char *fn = FileName;
+	int ln = LineNumber;
+	struct scope *newsc = CurrentScope;
+
+	level += incr;
+	df = lookup(id, GlobalScope, 1);
+	if (!df) {
+		/* Read definition module. Make an exception for SYSTEM.
+		*/
+		DefId = id;
+		if (!strcmp(id->id_text, "SYSTEM")) {
+			do_SYSTEM();
+			df = lookup(id, GlobalScope, 1);
+		}
+		else {
+			extern int ForeignFlag;
+
+			ForeignFlag = 0;
+			open_scope(CLOSEDSCOPE);
+			newsc = CurrentScope;
+			if (!is_anon_idf(id) && GetFile(id->id_text)) {
+
+				DefModule();
+				df = lookup(id, GlobalScope, 1);
+				if (level == 1 &&
+				    (!df || !(df->df_flags & D_FOREIGN))) {
+					/* The module is directly imported by
+					   the currently defined module, and
+					   is not foreign, so we have to
+					   remember its name because we have 
+					   to call its initialization routine
+					*/
+					static struct node *nd_end;
+					register struct node *n;
+					extern struct node *Modules;
+
+					n = dot2leaf(Name);
+					n->nd_IDF = id;
+					n->nd_symb = IDENT;
+					if (nd_end) nd_end->nd_left = n;
+					else Modules = n;
+					nd_end = n;
+				}
+			}
+			else {
+				df = lookup(id, GlobalScope, 1);
+				newsc->sc_name = id->id_text;
+			}
+			vis = CurrVis;
+			close_scope(SC_CHKFORW);
+		}
+		if (! df) {
+			df = MkDef(id, GlobalScope, D_ERROR);
+			df->df_type = error_type;
+			df->mod_vis = vis;
+			newsc->sc_definedby = df;
+		}
+	}
+	else if (df->df_flags & D_BUSY) {
+		error("definition module \"%s\" depends on itself",
+			id->id_text);
+	}
+	else if (df == Defined && level == 1) {
+		error("cannot import from current module \"%s\"", id->id_text);
+		df->df_kind = D_ERROR;
+	}
+	FileName = fn;
+	LineNumber = ln;
+	assert(df);
+	level -= incr;
+	return df;
+}

lang/m2/comp/desig.H

@@ -0,0 +1,65 @@
+/*
+ * (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
+ */
+
+/* D E S I G N A T O R   D E S C R I P T I O N S */
+
+/* $Header$ */
+
+/* Generating code for designators is not particularly easy, especially if
+   you don't know wether you want the address or the value.
+   The next structure is used to generate code for designators.
+   It contains information on how to find the designator, after generation
+   of the code that is common to both address and value computations.
+*/
+
+struct desig {
+	int	dsg_kind;
+#define DSG_INIT	0	/* don't know anything yet */
+#define DSG_LOADED	1	/* designator loaded  on top of the stack */
+#define DSG_PLOADED	2	/* designator accessible through pointer on
+				   stack, possibly with an offset
+				*/
+#define DSG_FIXED	3	/* designator directly accessible */
+#define DSG_PFIXED	4	/* designator accessible through directly
+				   accessible pointer
+				*/
+#define DSG_INDEXED	5	/* designator accessible through array
+				   operation. Address of array descriptor on
+				   top of the stack, index beneath that, and
+				   base address beneath that
+				*/
+	arith	dsg_offset;	/* contains an offset for PLOADED,
+				   or for FIXED or PFIXED it contains an
+				   offset from dsg_name, if it exists,
+				   or from the current Local Base
+				*/
+	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.
+   We have a linked list of them, as with-statements may be nested.
+*/
+
+struct withdesig {
+	struct withdesig *w_next;
+	struct scope *w_scope;	/* scope in which fields of this record
+				   reside
+				*/
+	struct desig w_desig;	/* a desig structure for this particular
+				   designator
+				*/
+};
+
+extern struct withdesig	*WithDesigs;
+extern struct desig	InitDesig;
+
+#define NO_LABEL	((label) 0)

lang/m2/comp/desig.c

@@ -0,0 +1,616 @@
+/*
+ * (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
+ */
+
+/* D E S I G N A T O R   E V A L U A T I O N */
+
+/* $Header$ */
+
+/*	Code generation for designators.
+   	This file contains some routines that generate code common to address
+	as well as value computations, and leave a description in a "desig"
+	structure.  It also contains routines to load an address, load a value
+	or perform a store.
+*/
+
+#include	"debug.h"
+
+#include	<em_arith.h>
+#include	<em_label.h>
+#include	<em_code.h>
+#include	<assert.h>
+#include	<alloc.h>
+
+#include	"type.h"
+#include	"LLlex.h"
+#include	"def.h"
+#include	"scope.h"
+#include	"desig.h"
+#include	"node.h"
+#include	"warning.h"
+
+extern int	proclevel;
+
+int
+WordOrDouble(ds, size)
+	register struct desig *ds;
+	arith size;
+{
+	return ((int) (ds->dsg_offset) % (int) word_size == 0 &&
+		( (int) size == (int) word_size ||
+		  (int) size == (int) dword_size));
+}
+
+int
+DoLoad(ds, size)
+	register struct desig *ds;
+	arith size;
+{
+	if (! WordOrDouble(ds, size)) return 0;
+	if (ds->dsg_name) {
+		if ((int) size == (int) word_size) {
+			C_loe_dnam(ds->dsg_name, ds->dsg_offset);
+		}
+		else	C_lde_dnam(ds->dsg_name, ds->dsg_offset);
+	}
+	else {
+		if ((int) size == (int) word_size) {
+			C_lol(ds->dsg_offset);
+		}
+		else	C_ldl(ds->dsg_offset);
+	}
+	return 1;
+}
+
+int
+DoStore(ds, size)
+	register struct desig *ds;
+	arith size;
+{
+	if (! WordOrDouble(ds, size)) return 0;
+	if (ds->dsg_name) {
+		if ((int) size == (int) word_size) {
+			C_ste_dnam(ds->dsg_name, ds->dsg_offset);
+		}
+		else	C_sde_dnam(ds->dsg_name, ds->dsg_offset);
+	}
+	else {
+		if ((int) size == (int) word_size) {
+			C_stl(ds->dsg_offset);
+		}
+		else	C_sdl(ds->dsg_offset);
+	}
+	return 1;
+}
+
+STATIC int
+properly(ds, tp)
+	register struct desig *ds;
+	register struct type *tp;
+{
+	/*	Check if it is allowed to load or store the value indicated
+		by "ds" with LOI/STI.
+		- if the size is not either a multiple or a dividor of the
+		  wordsize, then not.
+		- if the alignment is at least "word" then OK.
+		- if size is dividor of word_size and alignment >= size then OK.
+		- otherwise check alignment of address. This can only be done
+		  with DSG_FIXED.
+	*/
+
+	int szmodword = (int) (tp->tp_size) % (int) word_size;
+						/* 0 if multiple of wordsize */
+	int wordmodsz = word_size % tp->tp_size;/* 0 if dividor of wordsize */
+
+	if (szmodword && wordmodsz) return 0;
+	if (tp->tp_align >= word_align) return 1;
+	if (szmodword && tp->tp_align >= szmodword) return 1;
+
+	return ds->dsg_kind == DSG_FIXED &&
+	       ((! szmodword && (int) (ds->dsg_offset) % word_align == 0) ||
+		(! wordmodsz && ds->dsg_offset % tp->tp_size == 0));
+}
+
+CodeValue(ds, tp)
+	register struct desig *ds;
+	register struct type *tp;
+{
+	/*	Generate code to load the value of the designator described
+		in "ds"
+	*/
+	arith sz;
+
+	switch(ds->dsg_kind) {
+	case DSG_LOADED:
+		break;
+
+	case DSG_FIXED:
+		if (DoLoad(ds, tp->tp_size)) break;
+		/* Fall through */
+	case DSG_PLOADED:
+	case DSG_PFIXED:
+		sz = WA(tp->tp_size);
+		if (properly(ds, tp)) {
+			CodeAddress(ds);
+			C_loi(tp->tp_size);
+			break;
+		}
+		if (ds->dsg_kind == DSG_PLOADED) {
+			sz -= pointer_size;
+
+			C_asp(-sz);
+			C_lor((arith) 1);
+			C_adp(sz);
+			C_loi(pointer_size);
+		}
+		else  {
+			C_asp(-sz);
+		}
+		CodeAddress(ds);
+		C_loc(tp->tp_size);
+		C_cal("_load");
+		C_asp(2 * word_size);
+		break;
+
+	case DSG_INDEXED:
+		C_lar(word_size);
+		break;
+
+	default:
+		crash("(CodeValue)");
+	}
+
+	ds->dsg_kind = DSG_LOADED;
+}
+
+ChkForFOR(nd)
+	struct node *nd;
+{
+	if (nd->nd_class == Def) {
+		register struct def *df = nd->nd_def;
+
+		if (df->df_flags & D_FORLOOP) {
+			node_warning(nd,
+				     W_ORDINARY,
+				     "assignment to FOR-loop control variable");
+			df->df_flags &= ~D_FORLOOP;
+		}
+	}
+}
+
+CodeStore(ds, tp)
+	register struct desig *ds;
+	register struct type *tp;
+{
+	/*	Generate code to store the value on the stack in the designator
+		described in "ds"
+	*/
+	struct desig save;
+
+	save = *ds;
+
+	switch(ds->dsg_kind) {
+	case DSG_FIXED:
+		if (DoStore(ds, tp->tp_size)) break;
+		/* Fall through */
+	case DSG_PLOADED:
+	case DSG_PFIXED:
+		CodeAddress(&save);
+		if (properly(ds, tp)) {
+			C_sti(tp->tp_size);
+			break;
+		}
+		C_loc(tp->tp_size);
+		C_cal("_store");
+		C_asp(2 * word_size + WA(tp->tp_size));
+		break;
+
+	case DSG_INDEXED:
+		C_sar(word_size);
+		break;
+
+	default:
+		crash("(CodeStore)");
+	}
+
+	ds->dsg_kind = DSG_INIT;
+}
+
+CodeCopy(lhs, rhs, sz, psize)
+	register struct desig *lhs, *rhs;
+	arith sz, *psize;
+{
+	struct desig l, r;
+
+	l = *lhs; r = *rhs;
+	*psize -= sz;
+	lhs->dsg_offset += sz;
+	rhs->dsg_offset += sz;
+	CodeAddress(&r);
+	C_loi(sz);
+	CodeAddress(&l);
+	C_sti(sz);
+}
+
+CodeMove(rhs, left, rtp)
+	register struct desig *rhs;
+	register struct node *left;
+	struct type *rtp;
+{
+	register struct desig *lhs = new_desig();
+	register struct type *tp = left->nd_type;
+	int	loadedflag = 0;
+
+	/*	Generate code for an assignment. Testing of type
+		compatibility and the like is already done.
+		Go through some (considerable) trouble to see if a BLM can be
+		generated.
+	*/
+
+	ChkForFOR(left);
+	switch(rhs->dsg_kind) {
+	case DSG_LOADED:
+		CodeDesig(left, lhs);
+		if (rtp->tp_fund == T_STRING) {
+			CodeAddress(lhs);
+			C_loc(rtp->tp_size);
+			C_loc(tp->tp_size);
+			C_cal("_StringAssign");
+			C_asp(word_size << 2);
+			break;
+		}
+		CodeStore(lhs, tp);
+		break;
+	case DSG_PLOADED:
+	case DSG_PFIXED:
+		CodeAddress(rhs);
+		if ((int) (tp->tp_size) % (int) word_size == 0 &&
+		    tp->tp_align >= (int) word_size) {
+			CodeDesig(left, lhs);
+			CodeAddress(lhs);
+			C_blm(tp->tp_size);
+			break;
+		}
+		CodeValue(rhs, tp);
+		CodeDStore(left);
+		break;
+	case DSG_FIXED:
+		CodeDesig(left, lhs);
+		if (lhs->dsg_kind == DSG_FIXED &&
+		    (int) (lhs->dsg_offset) % (int) word_size ==
+		    (int) (rhs->dsg_offset) % (int) word_size) {
+			register int sz;
+			arith size = tp->tp_size;
+
+			while (size &&
+			       (sz = ((int)(lhs->dsg_offset) % (int)word_size))) {
+				/*	First copy up to word-aligned
+					boundaries
+				*/
+				if (sz < 0) sz = -sz;	/* bloody '%' */
+				while ((int) word_size % sz) sz--;
+				CodeCopy(lhs, rhs, (arith) sz, &size);
+			}
+			if (size > 3*dword_size) {
+				/*	Do a block move
+				*/
+				struct desig l, r;
+				arith sz;
+
+				sz = (size / word_size) * word_size;
+				l = *lhs; r = *rhs;
+				CodeAddress(&r);
+				CodeAddress(&l);
+				C_blm((arith) sz);
+				rhs->dsg_offset += sz;
+				lhs->dsg_offset += sz;
+				size -= sz;
+			}
+			else for (sz = (int) dword_size; sz; sz -= (int) word_size) {
+				while (size >= sz) {
+					/*	Then copy dwords, words.
+						Depend on peephole optimizer
+					*/
+					CodeCopy(lhs, rhs, (arith) sz, &size);
+				}
+			}
+			sz = word_size;
+			while (size && --sz) {
+				/*	And then copy remaining parts
+				*/
+				while ((int) word_size % sz) sz--;
+				while (size >= sz) {
+					CodeCopy(lhs, rhs, (arith) sz, &size);
+				}
+			}
+			break;
+		}
+		if (lhs->dsg_kind == DSG_PLOADED ||
+		    lhs->dsg_kind == DSG_INDEXED) {
+			CodeAddress(lhs);
+			loadedflag = 1;
+		}
+		if ((int)(tp->tp_size) % (int) word_size == 0 &&
+		    tp->tp_align >= word_size) {
+			CodeAddress(rhs);
+			if (loadedflag) C_exg(pointer_size);
+			else CodeAddress(lhs);
+			C_blm(tp->tp_size);
+			break;
+		}
+		{
+			arith tmp;
+			extern arith NewPtr();
+
+			if (loadedflag) {	
+				tmp = NewPtr();
+				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);
+			CodeStore(lhs, tp);
+			if (loadedflag) FreePtr(tmp);
+			break;
+		}
+	default:
+		crash("CodeMove");
+	}
+	free_desig(lhs);
+}
+
+CodeAddress(ds)
+	register struct desig *ds;
+{
+	/*	Generate code to load the address of the designator described
+	   	in "ds"
+	*/
+
+	switch(ds->dsg_kind) {
+	case DSG_PLOADED:
+		if (ds->dsg_offset) {
+			C_adp(ds->dsg_offset);
+		}
+		break;
+
+	case DSG_FIXED:
+		if (ds->dsg_name) {
+			C_lae_dnam(ds->dsg_name, ds->dsg_offset);
+			break;
+		}
+		C_lal(ds->dsg_offset);
+		if (ds->dsg_def) ds->dsg_def->df_flags |= D_NOREG;
+		break;
+		
+	case DSG_PFIXED:
+		DoLoad(ds, word_size);
+		break;
+
+	case DSG_INDEXED:
+		C_aar(word_size);
+		break;
+
+	default:
+		crash("(CodeAddress)");
+	}
+
+	ds->dsg_offset = 0;
+	ds->dsg_kind = DSG_PLOADED;
+}
+
+CodeFieldDesig(df, ds)
+	register struct def *df;
+	register struct desig *ds;
+{
+	/* Generate code for a field designator. Only the code common for
+	   address as well as value computation is generated, and the
+	   resulting information on where to find the designator is placed
+	   in "ds". "df" indicates the definition of the field.
+	*/
+
+	if (ds->dsg_kind == DSG_INIT) {
+		/* In a WITH statement. We must find the designator in the
+		   WITH statement, and act as if the field is a selection
+		   of this designator.
+		   So, first find the right WITH statement, which is the
+		   first one of the proper record type, which is
+		   recognized by its scope indication.
+		*/
+		register struct withdesig *wds = WithDesigs;
+
+		assert(wds != 0);
+
+		while (wds->w_scope != df->df_scope) {
+			wds = wds->w_next;
+			assert(wds != 0);
+		}
+
+		/* Found it. Now, act like it was a selection.
+		*/
+		*ds = wds->w_desig;
+		assert(ds->dsg_kind == DSG_PFIXED);
+	}
+
+	switch(ds->dsg_kind) {
+	case DSG_PLOADED:
+	case DSG_FIXED:
+		ds->dsg_offset += df->fld_off;
+		break;
+
+	case DSG_PFIXED:
+	case DSG_INDEXED:
+		CodeAddress(ds);
+		ds->dsg_kind = DSG_PLOADED;
+		ds->dsg_offset = df->fld_off;
+		break;
+
+	default:
+		crash("(CodeFieldDesig)");
+	}
+}
+
+CodeVarDesig(df, ds)
+	register struct def *df;
+	register struct desig *ds;
+{
+	/*	Generate code for a variable represented by a "def" structure.
+		Of course, there are numerous cases: the variable is local,
+		it is a value parameter, it is a var parameter, it is one of
+		those of an enclosing procedure, or it is global.
+	*/
+	register struct scope *sc = df->df_scope;
+
+	/* Selections from a module are handled earlier, when identifying
+	   the variable, so ...
+	*/
+	assert(ds->dsg_kind == DSG_INIT);
+
+	if (df->df_flags & D_ADDRGIVEN) {
+		/* the programmer specified an address in the declaration of
+		   the variable. Generate code to push the address.
+		*/
+		CodeConst(df->var_off, (int) pointer_size);
+		ds->dsg_kind = DSG_PLOADED;
+		ds->dsg_offset = 0;
+		return;
+	}
+
+	if (df->var_name) {
+		/* this variable has been given a name, so it is global.
+		   It is directly accessible.
+		*/
+		ds->dsg_name = df->var_name;
+		ds->dsg_offset = 0;
+		ds->dsg_kind = DSG_FIXED;
+		return;
+	}
+
+	if (sc->sc_level != proclevel) {
+		/* the variable is local to a statically enclosing procedure.
+		*/
+		assert(proclevel > sc->sc_level);
+
+		df->df_flags |= D_NOREG;
+		if (df->df_flags & (D_VARPAR|D_VALPAR)) {
+			/* value or var parameter
+			*/
+			C_lxa((arith) (proclevel - sc->sc_level));
+			if ((df->df_flags & D_VARPAR) ||
+			    IsConformantArray(df->df_type)) {
+				/* var parameter or conformant array.
+				   For conformant array's, the address is
+				   passed.
+				*/
+				C_adp(df->var_off);
+				C_loi(pointer_size);
+				ds->dsg_offset = 0;
+				ds->dsg_kind = DSG_PLOADED;
+				return;
+			}
+		}
+		else	C_lxl((arith) (proclevel - sc->sc_level));
+		ds->dsg_kind = DSG_PLOADED;
+		ds->dsg_offset = df->var_off;
+		return;
+	}
+
+	/* Now, finally, we have a local variable or a local parameter
+	*/
+	if ((df->df_flags & D_VARPAR) || IsConformantArray(df->df_type)) {
+		/* a var parameter; address directly accessible.
+		*/
+		ds->dsg_kind = DSG_PFIXED;
+	}
+	else	ds->dsg_kind = DSG_FIXED;
+	ds->dsg_offset = df->var_off;
+	ds->dsg_def = df;
+}
+
+CodeDesig(nd, ds)
+	register struct node *nd;
+	register struct desig *ds;
+{
+	/*	Generate code for a designator. Use divide and conquer
+		principle
+	*/
+	register struct def *df;
+
+	switch(nd->nd_class) {	/* Divide */
+	case Def:
+		df = nd->nd_def;
+		if (nd->nd_left) CodeDesig(nd->nd_left, ds);
+
+		switch(df->df_kind) {
+		case D_FIELD:
+			CodeFieldDesig(df, ds);
+			break;
+
+		case D_VARIABLE:
+			CodeVarDesig(df, ds);
+			break;
+
+		default:
+			crash("(CodeDesig) Def");
+		}
+		break;
+
+	case Arrsel:
+		assert(nd->nd_symb == '[');
+
+		CodeDesig(nd->nd_left, ds);
+		CodeAddress(ds);
+		CodePExpr(nd->nd_right);
+
+		/* Now load address of descriptor
+		*/
+		if (IsConformantArray(nd->nd_left->nd_type)) {
+			assert(nd->nd_left->nd_class == Def);
+
+			df = nd->nd_left->nd_def;
+			if (proclevel > df->df_scope->sc_level) {
+				C_lxa((arith) (proclevel - df->df_scope->sc_level));
+				C_adp(df->var_off + pointer_size);
+			}
+			else	C_lal(df->var_off + pointer_size);
+		}
+		else	{
+			C_lae_dlb(nd->nd_left->nd_type->arr_descr, (arith) 0);
+		}
+		ds->dsg_kind = DSG_INDEXED;
+		break;
+
+	case Arrow:
+		assert(nd->nd_symb == '^');
+
+		CodeDesig(nd->nd_right, ds);
+		switch(ds->dsg_kind) {
+		case DSG_LOADED:
+			ds->dsg_kind = DSG_PLOADED;
+			break;
+
+		case DSG_INDEXED:
+		case DSG_PLOADED:
+		case DSG_PFIXED:
+			CodeValue(ds, nd->nd_right->nd_type);
+			ds->dsg_kind = DSG_PLOADED;
+			ds->dsg_offset = 0;
+			break;
+
+		case DSG_FIXED:
+			ds->dsg_kind = DSG_PFIXED;
+			break;
+
+		default:
+			crash("(CodeDesig) Uoper");
+		}
+		break;
+		
+	default:
+		crash("(CodeDesig) class");
+	}
+}

lang/m2/comp/em_m2.6

@@ -0,0 +1,84 @@
+.TH EM_M2 6ACK
+.ad
+.SH NAME
+em_m2 \- ACK Modula\-2 compiler
+.SH SYNOPSIS
+.B em_m2
+.RI [ option ] 
+.I source
+.I destination
+.SH DESCRIPTION
+.I Em_m2
+is a
+compiler, part of the Amsterdam Compiler Kit, that translates Modula-2 programs
+into EM code.
+The input is taken from
+.IR source ,
+while the
+EM code is written on 
+.IR destination .
+.br
+.I Option
+is a, possibly empty, sequence of the following combinations:
+.IP \fB\-I\fIdirname\fR
+.br
+append \fIdirname\fR to the list of directories where definition modules
+are looked for.
+.PP
+When the compiler needs a definition module, it is first searched for
+in the current directory, and then in the directories given to it by the
+\-\fBI\fR flag
+in the order given.
+.IP \fB\-M\fP\fIn\fP
+set maximum identifier length to \fIn\fP.
+The minimum value for \fIn\fR is 14, because the keyword
+"IMPLEMENTATION" is that long.
+.IP \fB\-n\fR
+do not generate EM register messages.
+The user-declared variables will not be stored into registers on the target
+machine.
+.IP \fB\-L\fR
+do not generate the EM \fBfil\fR and \fBlin\fR instructions that enable
+an interpreter to keep track of the current location in the source code.
+.IP \fB\-V\fIcm\fR.\fIn\fR,\ \fB\-V\fIcm\fR.\fIncm\fR.\fIn\fR\ ...
+.br
+set the size and alignment requirements.
+The letter \fIc\fR indicates the simple type, which is one of
+\fBw\fR(word size), \fBi\fR(INTEGER), \fBl\fR(LONGINT), \fBf\fR(REAL),
+\fBd\fR(LONGREAL), or \fBp\fR(POINTER).
+It may also be the letter \fBS\fR, indicating that an initial
+record alignment follows.
+The \fIm\fR parameter can be used to specify the length of the type (in bytes)
+and the \fIn\fR parameter for the alignment of that type.
+Absence of \fIm\fR or \fIn\fR causes a default value to be retained.
+.IP \fB\-w\fR\fIclasses\fR
+suppress warning messages whose class is a member of \fIclasses\fR.
+Currently, there are three classes: \fBO\fR, indicating old-flashioned use,
+\fBW\fR, indicating "ordinary" warnings, and \fBR\fR, indicating
+restricted Modula-2.
+If no \fIclasses\fR are given, all warnings are suppressed.
+By default, warnings in class \fBO\fR and \fBW\fR are given.
+.IP \fB\-W\fR\fIclasses\fR
+allow for warning messages whose class is a member of \fIclasses\fR.
+.IP \fB\-x\fR
+make all procedure names global, so that \fIadb\fR(1) understands them.
+.IP \fB\-i\fR\fInum\fR
+maximum number of bits in a set. When not used, a default value is
+retained.
+.IP \fB\-s\fR
+make INTEGER ranges symmetric, t.i., MIN(INTEGER) = - MAX(INTEGER).
+This is useful for interpreters that use the "real" MIN(INTEGER) to
+indicate "undefined".
+.IP \fB-R\fR
+disable all range checks.
+.LP
+.SH FILES
+.IR ~em/lib/em_m2 :
+binary of the Modula-2 compiler.
+.SH SEE ALSO
+\fIack\fR(1), \fImodula-2\fR(1)
+.SH DIAGNOSTICS
+All warning and error messages are written on standard error output.
+.SH REMARKS
+Debugging and profiling facilities may be present during the development
+of \fIem_m2\fP.

lang/m2/comp/enter.c

@@ -0,0 +1,479 @@
+/*
+ * (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
+ */
+
+/* H I G H   L E V E L   S Y M B O L   E N T R Y */
+
+/* $Header$ */
+
+#include	"debug.h"
+
+#include	<alloc.h>
+#include	<em_arith.h>
+#include	<em_label.h>
+#include	<em_code.h>
+#include	<assert.h>
+
+#include	"idf.h"
+#include	"LLlex.h"
+#include	"def.h"
+#include	"type.h"
+#include	"scope.h"
+#include	"node.h"
+#include	"main.h"
+#include	"misc.h"
+#include	"f_info.h"
+
+struct def *
+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.
+	*/
+	register struct def *df;
+
+	df = define(str2idf(name, 0), CurrentScope, kind);
+	df->df_type = type;
+	if (pnam) df->df_value.df_stdname = pnam;
+	return df;
+}
+
+EnterType(name, type)
+	char *name;
+	struct type *type;
+{
+	/*	Enter a type definition for "name"  and type
+		"type" in the Current Scope.
+	*/
+
+	Enter(name, D_TYPE, type, 0);
+}
+
+EnterEnumList(Idlist, type)
+	struct node *Idlist;
+	register struct type *type;
+{
+	/*	Put a list of enumeration literals in the symbol table.
+		They all have type "type".
+		Also assign numbers to them, and link them together.
+		We must link them together because an enumeration type may
+		be exported, in which case its literals must also be exported.
+		Thus, we need an easy way to get to them.
+	*/
+	register struct def *df;
+	register struct node *idlist = Idlist;
+
+	type->enm_ncst = 0;
+	for (; idlist; idlist = idlist->nd_left) {
+		df = define(idlist->nd_IDF, CurrentScope, D_ENUM);
+		df->df_type = type;
+		df->enm_val = (type->enm_ncst)++;
+		df->enm_next = type->enm_enums;
+		type->enm_enums = df;
+	}
+	FreeNode(Idlist);
+}
+
+EnterFieldList(Idlist, type, scope, addr)
+	struct node *Idlist;
+	register struct type *type;
+	struct scope *scope;
+	arith *addr;
+{
+	/*	Put a list of fields in the symbol table.
+		They all have type "type", and are put in scope "scope".
+		Mark them as QUALIFIED EXPORT, because that's exactly what
+		fields are, you can get to them by qualifying them.
+	*/
+	register struct def *df;
+	register struct node *idlist = Idlist;
+
+	for (; idlist; idlist = idlist->nd_left) {
+		df = define(idlist->nd_IDF, scope, D_FIELD);
+		df->df_type = type;
+		df->df_flags |= D_QEXPORTED;
+		df->fld_off = align(*addr, type->tp_align);
+		*addr = df->fld_off + type->tp_size;
+	}
+	FreeNode(Idlist);
+}
+
+EnterVarList(Idlist, type, local)
+	struct node *Idlist;
+	struct type *type;
+{
+	/*	Enter a list of identifiers representing variables into the
+		name list. "type" represents the type of the variables.
+		"local" is set if the variables are declared local to a
+		procedure.
+	*/
+	register struct def *df;
+	register struct node *idlist = Idlist;
+	register struct scopelist *sc = CurrVis;
+	char buf[256];
+	extern char *sprint();
+
+	if (local) {
+		/* Find the closest enclosing open scope. This
+		   is the procedure that we are dealing with
+		*/
+		while (sc->sc_scope->sc_scopeclosed) sc = enclosing(sc);
+	}
+
+	for (; idlist; idlist = idlist->nd_right) {
+		df = define(idlist->nd_IDF, CurrentScope, D_VARIABLE);
+		df->df_type = type;
+		if (idlist->nd_left) {
+			/* An address was supplied
+			*/
+			register struct type *tp = idlist->nd_left->nd_type;
+
+			df->df_flags |= D_ADDRGIVEN | D_NOREG;
+			if (tp != error_type && !(tp->tp_fund & T_CARDINAL)){
+				node_error(idlist->nd_left,
+					   "illegal type for address");
+			}
+			df->var_off = idlist->nd_left->nd_INT;
+		}
+		else if (local) {
+			/* subtract aligned size of variable to the offset,
+			   as the variable list exists only local to a
+			   procedure
+			*/
+			sc->sc_scope->sc_off =
+				-WA(align(type->tp_size - sc->sc_scope->sc_off,
+						type->tp_align));
+			df->var_off = sc->sc_scope->sc_off;
+		}
+		else {
+			/* Global name, possibly external
+			*/
+			if (sc->sc_scope->sc_definedby->df_flags & D_FOREIGN) {
+				df->var_name = df->df_idf->id_text;
+			}
+			else {
+				sprint(buf,"%s_%s", sc->sc_scope->sc_name,
+					    df->df_idf->id_text);
+				df->var_name = Salloc(buf,
+						(unsigned)(strlen(buf)+1));
+			}
+			df->df_flags |= D_NOREG;
+
+ 			if (DefinitionModule) {
+				if (sc == Defined->mod_vis) {
+					C_exa_dnam(df->var_name);
+				}
+			}
+			else {
+				C_ina_dnam(df->var_name);
+			}
+		}
+	}
+	FreeNode(Idlist);
+}
+
+EnterParamList(ppr, Idlist, type, VARp, off)
+	struct paramlist **ppr;
+	struct node *Idlist;
+	struct type *type;
+	int VARp;
+	arith *off;
+{
+	/*	Create (part of) a parameterlist of a procedure.
+		"ids" indicates the list of identifiers, "tp" their type, and
+		"VARp" indicates D_VARPAR or D_VALPAR.
+	*/
+	register struct paramlist *pr;
+	register struct def *df;
+	register struct node *idlist = Idlist;
+	struct node *dummy = 0;
+	static struct paramlist *last;
+
+	if (! idlist) {
+		/* Can only happen when a procedure type is defined */
+		dummy = Idlist = idlist = dot2leaf(Name);
+	}
+	for ( ; idlist; idlist = idlist->nd_left) {
+		pr = new_paramlist();
+		pr->par_next = 0;
+		if (!*ppr) *ppr = pr;
+		else	last->par_next = pr;
+		last = pr;
+		if (!DefinitionModule && idlist != dummy) {
+			df = define(idlist->nd_IDF, CurrentScope, D_VARIABLE);
+			df->var_off = *off;
+		}
+		else	df = new_def();
+		pr->par_def = df;
+		df->df_type = type;
+		df->df_flags = VARp;
+
+		if (IsConformantArray(type)) {
+			/* we need room for the base address and a descriptor
+			*/
+			*off += pointer_size + 3 * word_size;
+		}
+		else if (VARp == D_VARPAR) {
+			*off += pointer_size;
+		}
+		else {
+			*off += WA(type->tp_size);
+		}
+	}
+	FreeNode(Idlist);
+}
+
+STATIC
+DoImport(df, scope)
+	register struct def *df;
+	struct scope *scope;
+{
+	/*	Definition "df" is imported to scope "scope".
+		Handle the case that it is an enumeration type or a module.
+	*/
+
+	define(df->df_idf, scope, D_IMPORT)->imp_def = df;
+
+	if (df->df_kind == D_TYPE && df->df_type->tp_fund == T_ENUMERATION) {
+		/* Also import all enumeration literals
+		*/
+		for (df = df->df_type->enm_enums; df; df = df->enm_next) {
+			define(df->df_idf, scope, D_IMPORT)->imp_def = df;
+		}
+	}
+	else if (df->df_kind == D_MODULE) {
+		/* Also import all definitions that are exported from this
+		   module
+		*/
+		if (df->mod_vis == CurrVis) {
+			error("cannot import current module \"%s\"",
+				df->df_idf->id_text);
+			return;
+		}
+		for (df = df->mod_vis->sc_scope->sc_def;
+		     df;
+		     df = df->df_nextinscope) {
+			if (df->df_flags & D_EXPORTED) {
+				define(df->df_idf,scope,D_IMPORT)->imp_def = df;
+			}
+		}
+	}
+}
+
+STATIC struct scopelist *
+ForwModule(df, nd)
+	register struct def *df;
+	struct node *nd;
+{
+	/*	An import is done from a not yet defined module "df".
+		We could also end up here for not found DEFINITION MODULES.
+		Create a declaration and a scope for this module.
+	*/
+	struct scopelist *vis;
+
+	if (df->df_scope != GlobalScope) {
+		df->df_scope = enclosing(CurrVis)->sc_scope;
+		df->df_kind = D_FORWMODULE;
+	}
+	open_scope(CLOSEDSCOPE);
+	vis = CurrVis;		/* The new scope, but watch out, it's "sc_encl"
+				   field is not set right. It must indicate the
+				   enclosing scope, but this must be done AFTER
+				   closing this one
+				*/
+	close_scope(0);	
+	vis->sc_encl = enclosing(CurrVis);
+				/* Here ! */
+	df->for_vis = vis;
+	df->for_node = nd;
+	return vis;
+}
+
+STATIC struct def *
+ForwDef(ids, scope)
+	register struct node *ids;
+	struct scope *scope;
+{
+	/*	Enter a forward definition of "ids" in scope "scope",
+		if it is not already defined.
+	*/
+	register struct def *df;
+
+	if (!(df = lookup(ids->nd_IDF, scope, 1))) {
+		df = define(ids->nd_IDF, scope, D_FORWARD);
+		df->for_node = MkLeaf(Name, &(ids->nd_token));
+	}
+	return df;
+}
+
+EnterExportList(Idlist, qualified)
+	struct node *Idlist;
+{
+	/*	From the current scope, the list of identifiers "ids" is
+		exported. Note this fact. If the export is not qualified, make
+		all the "ids" visible in the enclosing scope by defining them
+		in this scope as "imported".
+	*/
+	register struct node *idlist = Idlist;
+	register struct def *df, *df1;
+
+	for (;idlist; idlist = idlist->nd_left) {
+		df = lookup(idlist->nd_IDF, CurrentScope, 0);
+
+		if (!df) {
+			/* undefined item in export list
+			*/
+			node_error(idlist,
+				   "identifier \"%s\" not defined",
+				   idlist->nd_IDF->id_text);
+			continue;
+		}
+
+		if (df->df_flags & (D_EXPORTED|D_QEXPORTED)) {
+			node_error(idlist,
+				"multiple occurrences of \"%s\" in export list",
+				idlist->nd_IDF->id_text);
+		}
+
+		if (df->df_kind == D_IMPORT) df = df->imp_def;
+
+		df->df_flags |= qualified;
+		if (qualified == D_EXPORTED) {
+			/* Export, but not qualified.
+			   Find all imports of the module in which this export
+			   occurs, and export the current definition to it
+			*/
+			df1 = CurrentScope->sc_definedby->df_idf->id_def;
+			while (df1) {
+				if (df1->df_kind == D_IMPORT &&
+				    df1->imp_def == CurrentScope->sc_definedby) {
+					DoImport(df, df1->df_scope);
+				}
+				df1 = df1->df_next;
+			}
+
+			/* Also handle the definition as if the enclosing
+			   scope imports it.
+			*/
+			df1 = lookup(idlist->nd_IDF,
+				     enclosing(CurrVis)->sc_scope, 1);
+			if (df1) {
+				/* It was already defined in the enclosing
+				   scope. There are two legal possibilities,
+				   which are examined below.
+				*/
+				if (df1->df_kind == D_PROCHEAD &&
+				     df->df_kind == D_PROCEDURE) {
+					df1->df_kind = D_IMPORT;
+					df1->imp_def = df;
+					continue;
+				}
+				if (df1->df_kind == D_HIDDEN &&
+				    df->df_kind == D_TYPE) {
+					DeclareType(idlist, df1, df->df_type);
+					df1->df_kind = D_TYPE;
+					continue;
+				}
+			}
+
+			DoImport(df, enclosing(CurrVis)->sc_scope);
+		}
+	}
+	FreeNode(Idlist);
+}
+
+EnterFromImportList(Idlist, FromDef, FromId)
+	struct node *Idlist;
+	register struct def *FromDef;
+	struct node *FromId;
+{
+	/*	Import the list Idlist from the module indicated by Fromdef.
+	*/
+	register struct node *idlist = Idlist;
+	register struct scopelist *vis;
+	register struct def *df;
+	char *module_name = FromDef->df_idf->id_text;
+	int forwflag = 0;
+
+	switch(FromDef->df_kind) {
+	case D_ERROR:
+		/* The module from which the import was done
+		   is not yet declared. I'm not sure if I must
+		   accept this, but for the time being I will.
+		   We also end up here if some definition module could not
+		   be found.
+		   ???
+		*/
+		vis = ForwModule(FromDef, FromId);
+		forwflag = 1;
+		break;
+	case D_FORWMODULE:
+		vis = FromDef->for_vis;
+		break;
+	case D_MODULE:
+		vis = FromDef->mod_vis;
+		if (vis == CurrVis) {
+node_error(FromId, "cannot import from current module \"%s\"", module_name);
+			return;
+		}
+		break;
+	default:
+node_error(FromId,"identifier \"%s\" does not represent a module",module_name);
+		return;
+	}
+
+	for (; idlist; idlist = idlist->nd_left) {
+		if (forwflag) df = ForwDef(idlist, vis->sc_scope);
+		else if (! (df = lookup(idlist->nd_IDF, vis->sc_scope, 1))) {
+			if (! is_anon_idf(idlist->nd_IDF)) {
+				node_error(idlist,
+			"identifier \"%s\" not declared in module \"%s\"",
+					idlist->nd_IDF->id_text,
+					module_name);
+			}
+			df = define(idlist->nd_IDF,vis->sc_scope,D_ERROR);
+		}
+		else if (! (df->df_flags & (D_EXPORTED|D_QEXPORTED))) {
+			node_error(idlist,
+			"identifier \"%s\" not exported from module \"%s\"",
+			idlist->nd_IDF->id_text,
+			module_name);
+			df->df_flags |= D_QEXPORTED;
+		}
+		DoImport(df, CurrentScope);
+	}
+
+	if (!forwflag) FreeNode(FromId);
+	FreeNode(Idlist);
+}
+
+EnterImportList(Idlist, local)
+	struct node *Idlist;
+{
+	/*	Import "Idlist" from the enclosing scope.
+		An exception must be made for imports of the compilation unit.
+		In this case, definition modules must be read for "Idlist".
+		This case is indicated by the value 0 of the "local" flag.
+	*/
+	register struct node *idlist = Idlist;
+	struct scope *sc = enclosing(CurrVis)->sc_scope;
+	extern struct def *GetDefinitionModule();
+	struct f_info f;
+	
+	f = file_info;
+
+	for (; idlist; idlist = idlist->nd_left) {
+		DoImport(local ?
+				ForwDef(idlist, sc) :
+				GetDefinitionModule(idlist->nd_IDF, 1) ,
+			 CurrentScope);
+		file_info = f;
+	}
+	FreeNode(Idlist);
+}

lang/m2/comp/error.c

@@ -0,0 +1,242 @@
+/*
+ * (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
+ */
+
+/* E R R O R   A N D   D I A G N O S T I C   R O U T I N E S */
+
+/* $Header$ */
+
+/*	This file contains the (non-portable) error-message and diagnostic
+	giving functions.  Be aware that they are called with a variable
+	number of arguments!
+*/
+
+#include	"errout.h"
+#include	"debug.h"
+
+#include	<system.h>
+#include	<em_arith.h>
+#include	<em_label.h>
+
+#include	"input.h"
+#include	"f_info.h"
+#include	"LLlex.h"
+#include	"main.h"
+#include	"node.h"
+#include	"warning.h"
+
+/* error classes */
+#define	ERROR		1
+#define	WARNING		2
+#define	LEXERROR	3
+#define	LEXWARNING	4
+#define	CRASH		5
+#define	FATAL		6
+#ifdef DEBUG
+#define VDEBUG		7
+#endif
+
+int err_occurred;
+static int warn_class;
+
+extern char *symbol2str();
+
+/*	There are three general error-message functions:
+		lexerror()	lexical and pre-processor error messages
+		error()		syntactic and semantic error messages
+		node_error()	errors in nodes
+	The difference lies in the place where the file name and line
+	number come from.
+	Lexical errors report from the global variables LineNumber and
+	FileName, node errors get their information from the
+	node, whereas other errors use the information in the token.
+*/
+
+#ifdef DEBUG
+/*VARARGS1*/
+debug(fmt, args)
+	char *fmt;
+{
+	_error(VDEBUG, NULLNODE, fmt, &args);
+}
+#endif DEBUG
+
+/*VARARGS1*/
+error(fmt, args)
+	char *fmt;
+{
+	_error(ERROR, NULLNODE, fmt, &args);
+}
+
+/*VARARGS2*/
+node_error(node, fmt, args)
+	struct node *node;
+	char *fmt;
+{
+	_error(ERROR, node, fmt, &args);
+}
+
+/*VARARGS1*/
+warning(class, fmt, args)
+	char *fmt;
+{
+	warn_class = class;
+	if (class & warning_classes) _error(WARNING, NULLNODE, fmt, &args);
+}
+
+/*VARARGS2*/
+node_warning(node, class, fmt, args)
+	struct node *node;
+	char *fmt;
+{
+	warn_class = class;
+	if (class & warning_classes) _error(WARNING, node, fmt, &args);
+}
+
+/*VARARGS1*/
+lexerror(fmt, args)
+	char *fmt;
+{
+	_error(LEXERROR, NULLNODE, fmt, &args);
+}
+
+/*VARARGS1*/
+lexwarning(class, fmt, args) 
+	char *fmt;
+{
+	warn_class = class;
+	if (class & warning_classes) _error(LEXWARNING, NULLNODE, fmt, &args);
+}
+
+/*VARARGS1*/
+fatal(fmt, args)
+	char *fmt;
+	int args;
+{
+
+	_error(FATAL, NULLNODE, fmt, &args);
+	sys_stop(S_EXIT);
+}
+
+/*VARARGS1*/
+crash(fmt, args)
+	char *fmt;
+	int args;
+{
+
+	_error(CRASH, NULLNODE, fmt, &args);
+#ifdef DEBUG
+	sys_stop(S_ABORT);
+#else
+	sys_stop(S_EXIT);
+#endif
+}
+
+_error(class, node, fmt, argv)
+	int class;
+	struct node *node;
+	char *fmt;
+	int argv[];
+{
+	/*	_error attempts to limit the number of error messages
+		for a given line to MAXERR_LINE.
+	*/
+	static unsigned int last_ln = 0;
+	unsigned int ln = 0;
+	static char * last_fn = 0;
+	static int e_seen = 0;
+	register char *remark = 0;
+	
+	/*	Since name and number are gathered from different places
+		depending on the class, we first collect the relevant
+		values and then decide what to print.
+	*/
+	/* preliminaries */
+	switch (class)	{
+	case ERROR:
+	case LEXERROR:
+	case CRASH:
+	case FATAL:
+		if (C_busy()) C_ms_err();
+		err_occurred = 1;
+		break;
+	}
+
+	/* the remark */
+	switch (class)	{	
+	case WARNING:
+	case LEXWARNING:
+		switch(warn_class) {
+		case W_OLDFASHIONED:
+			remark = "(old-fashioned use)";
+			break;
+		case W_STRICT:
+			remark = "(strict)";
+			break;
+		default:
+			remark = "(warning)";
+			break;
+		}
+		break;
+	case CRASH:
+		remark = "CRASH\007";
+		break;
+	case FATAL:
+		remark = "fatal error --";
+		break;
+#ifdef DEBUG
+	case VDEBUG:
+		remark = "(debug)";
+		break;
+#endif DEBUG
+	}
+	
+	/* the place */
+	switch (class)	{	
+	case WARNING:
+	case ERROR:
+		ln = node ? node->nd_lineno : dot.tk_lineno;
+		break;
+	case LEXWARNING:
+	case LEXERROR:
+	case CRASH:
+	case FATAL:
+#ifdef DEBUG
+	case VDEBUG:
+#endif DEBUG
+		ln = LineNumber;
+		break;
+	}
+	
+#ifdef DEBUG
+	if (class != VDEBUG) {
+#endif
+	if (FileName == last_fn && ln == last_ln)	{
+		/* we've seen this place before */
+		e_seen++;
+		if (e_seen == MAXERR_LINE) fmt = "etc ...";
+		else
+		if (e_seen > MAXERR_LINE)
+			/* and too often, I'd say ! */
+			return;
+	}
+	else	{
+		/* brand new place */
+		last_ln = ln;
+		last_fn = FileName;
+		e_seen = 0;
+	}
+#ifdef DEBUG
+	}
+#endif DEBUG
+	
+	if (FileName) fprint(ERROUT, "\"%s\", line %u: ", FileName, ln);
+
+	if (remark) fprint(ERROUT, "%s ", remark);
+
+	doprnt(ERROUT, fmt, argv);		/* contents of error */
+	fprint(ERROUT, "\n");
+}

lang/m2/comp/expression.g

@@ -0,0 +1,290 @@
+/*
+ * (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
+ */
+
+/* E X P R E S S I O N S */
+
+/* $Header$ */
+
+{
+#include	"debug.h"
+
+#include	<alloc.h>
+#include	<em_arith.h>
+#include	<em_label.h>
+#include	<assert.h>
+
+#include	"LLlex.h"
+#include	"idf.h"
+#include	"def.h"
+#include	"node.h"
+#include	"const.h"
+#include	"type.h"
+#include	"chk_expr.h"
+#include	"warning.h"
+
+extern char	options[];
+}
+
+/* inline, we need room for pdp/11
+number(struct node **p;) :
+[
+	%default
+	INTEGER
+|
+	REAL
+]			{ *p = dot2leaf(Value);
+			  (*p)->nd_type = toktype;
+			}
+;
+*/
+
+qualident(struct node **p;)
+{
+} :
+	IDENT	{ *p = dot2leaf(Name); }
+	[
+		selector(p)
+	]*
+;
+
+selector(struct node **pnd;):
+	'.'	{ *pnd = dot2node(Link,*pnd,NULLNODE); }
+	IDENT	{ (*pnd)->nd_IDF = dot.TOK_IDF; }
+;
+
+ExpList(struct node **pnd;)
+{
+	register struct node *nd;
+} :
+	expression(pnd)		{ *pnd = nd = dot2node(Link,*pnd,NULLNODE);
+				  nd->nd_symb = ',';
+				}
+	[
+		','		{ nd->nd_right = dot2leaf(Link);
+				  nd = nd->nd_right;
+				}
+		expression(&(nd->nd_left))
+	]*
+;
+
+ConstExpression(struct node **pnd;)
+{
+	register struct node *nd;
+}:
+	expression(pnd)
+	/*
+	 * Changed rule in new Modula-2.
+	 * Check that the expression is a constant expression and evaluate!
+	 */
+		{ nd = *pnd;
+		  DO_DEBUG(options['C'], print("CONSTANT EXPRESSION\n"));
+		  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['C'], print("RESULTS IN\n"));
+		  DO_DEBUG(options['C'], PrNode(nd, 0));
+		}
+;
+
+expression(struct node **pnd;)
+{
+} :
+	SimpleExpression(pnd)
+	[
+		/* relation */
+		[ '=' | '#' | '<' | LESSEQUAL | '>' | GREATEREQUAL | IN ]
+			{ *pnd = dot2node(Oper, *pnd, NULLNODE); }
+		SimpleExpression(&((*pnd)->nd_right))
+	]?
+;
+
+/* Inline in expression
+relation:
+	'=' | '#' | '<' | LESSEQUAL | '>' | GREATEREQUAL | IN
+;
+*/
+
+SimpleExpression(struct node **pnd;)
+{
+	register struct node *nd = 0;
+} :
+	[
+		[ '+' | '-' ]
+			{ nd = dot2leaf(Uoper);
+			  /* priority of unary operator ??? */
+			}
+	]?
+	term(pnd)
+			{ if (nd) {
+				nd->nd_right = *pnd;
+				*pnd = nd;
+			  }
+			  nd = *pnd;
+			}
+	[
+		/* AddOperator */
+		[ '+' | '-' | OR ]
+			{ nd = dot2node(Oper, nd, NULLNODE); }
+		term(&(nd->nd_right))
+	]*
+			{ *pnd = nd; }
+;
+
+/* Inline in "SimpleExpression"
+AddOperator:
+	'+' | '-' | OR
+;
+*/
+
+term(struct node **pnd;)
+{
+	register struct node *nd;
+}:
+	factor(pnd)	{ nd = *pnd; }
+	[
+		/* MulOperator */
+		[ '*' | '/' | DIV | MOD | AND ]
+			{ nd = dot2node(Oper, nd, NULLNODE); }
+		factor(&(nd->nd_right))
+	]*
+			{ *pnd = nd; }
+;
+
+/* inline in "term"
+MulOperator:
+	'*' | '/' | DIV | MOD | AND
+;
+*/
+
+factor(register struct node **p;)
+{
+	struct node *nd;
+} :
+	qualident(p)
+	[
+		designator_tail(p)?
+		[
+			{ *p = dot2node(Call, *p, NULLNODE); }
+			ActualParameters(&((*p)->nd_right))
+		]?
+	|
+		bare_set(&nd)
+			{ nd->nd_left = *p; *p = nd; }
+	]
+|
+	bare_set(p)
+| %default
+	[
+		%default
+		INTEGER
+	|
+		REAL
+	|
+		STRING
+	]		{ *p = dot2leaf(Value);
+			  (*p)->nd_type = toktype;
+			}
+|
+	'(' 	{ nd = dot2leaf(Uoper); }
+	expression(p)
+		{ /*	In some cases we must leave the '(' as an unary
+			operator, because otherwise we cannot see that the
+			factor was not a designator
+		  */
+		  register int class = (*p)->nd_class;
+
+		  if (class == Arrsel ||
+		      class == Arrow ||
+		      class == Name ||
+		      class == Link) {
+			nd->nd_right = *p;
+			*p = nd;
+		  }
+		  else free_node(nd);
+		}
+	')'
+|
+	NOT		{ *p = dot2leaf(Uoper); }
+	factor(&((*p)->nd_right))
+;
+
+bare_set(struct node **pnd;)
+{
+	register struct node *nd;
+} :
+	'{'		{ dot.tk_symb = SET;
+			  *pnd = nd = dot2leaf(Xset);
+			  nd->nd_type = bitset_type;
+			}
+	[
+		element(nd)
+		[	{ nd = nd->nd_right; }
+			',' element(nd)
+		]*
+	]?
+	'}'
+;
+
+ActualParameters(struct node **pnd;):
+	'(' ExpList(pnd)? ')'
+;
+
+element(register struct node *nd;)
+{
+	struct node *nd1;
+} :
+	expression(&nd1)
+	[
+		UPTO
+			{ nd1 = dot2node(Link, nd1, NULLNODE);}
+		expression(&(nd1->nd_right))
+	]?
+			{ nd->nd_right = dot2node(Link, nd1, NULLNODE);
+			  nd->nd_right->nd_symb = ',';
+			}
+;
+
+designator(struct node **pnd;)
+:
+	qualident(pnd)
+	designator_tail(pnd)?
+;
+
+designator_tail(struct node **pnd;):
+	visible_designator_tail(pnd)
+	[ %persistent
+		%default
+		selector(pnd)
+	|
+		visible_designator_tail(pnd)
+	]*
+;
+
+visible_designator_tail(struct node **pnd;)
+{
+	register struct node *nd = *pnd;
+}:
+[
+	'['		{ nd = dot2node(Arrsel, nd, NULLNODE); }
+		expression(&(nd->nd_right))
+		[
+			','
+			{ nd = dot2node(Arrsel, nd, NULLNODE);
+			  nd->nd_symb = '[';
+			}
+			expression(&(nd->nd_right))
+		]*
+	']'
+|
+	'^'		{ nd = dot2node(Arrow, NULLNODE, nd); }
+]
+			{ *pnd = nd; }
+;

lang/m2/comp/f_info.h

@@ -0,0 +1,21 @@
+/*
+ * (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
+ */
+
+/* F I L E   D E S C R I P T O R   S T R U C T U R E */
+
+/* $Header$ */
+
+struct f_info {
+	unsigned short f_lineno;
+	char *f_filename;
+	char *f_workingdir;
+};
+
+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/idf.c

@@ -0,0 +1,13 @@
+/*
+ * (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
+ */
+
+/* I N S T A N T I A T I O N   O F   I D F   P A C K A G E */
+
+/* $Header$ */
+
+#include	"idf.h"
+#include	<idf_pkg.body>

lang/m2/comp/idf.h

@@ -0,0 +1,21 @@
+/*
+ * (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
+ */
+
+/* U S E R   D E C L A R E D   P A R T   O F   I D F */
+
+/* $Header$ */
+
+struct id_u {
+	int id_res;
+	struct def *id_df;
+};
+
+#define IDF_TYPE	struct id_u
+#define id_reserved	id_user.id_res
+#define id_def		id_user.id_df
+
+#include	<idf_pkg.spec>

lang/m2/comp/idlist.H

@@ -0,0 +1,12 @@
+/* $Header$ */
+
+#include <alloc.h>
+
+/*	Structure to link idf structures together
+*/
+struct id_list {
+	struct id_list *next;
+	struct idf *id_ptr;
+};
+
+/* ALLOCDEF "id_list" */

lang/m2/comp/idlist.c

@@ -0,0 +1,20 @@
+static char *RcsId = "$Header$";
+
+#include "idf.h"
+#include "idlist.h"
+
+struct id_list *h_id_list;	/* Header of free list */
+
+/*	FreeIdList: take a list of id_list structures and put them
+	on the free list of id_list structures
+*/
+FreeIdList(p)
+	struct id_list *p;
+{
+	register struct id_list *q;
+
+	while (q = p) {
+		p = p->next;
+		free_id_list(q);
+	}
+}

lang/m2/comp/input.c

@@ -0,0 +1,31 @@
+/*
+ * (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
+ */
+
+/* I N S T A N T I A T I O N   O F   I N P U T   P A C K A G E */
+
+/* $Header$ */
+
+#include	"f_info.h"
+struct f_info	file_info;
+#include	"input.h"
+#include	<inp_pkg.body>
+
+
+AtEoIF()
+{
+	/*	Make the unstacking of input streams noticable to the
+	   	lexical analyzer
+	*/
+	return 1;
+}
+
+AtEoIT()
+{
+	/*	Make the end of the text noticable
+	*/
+	return 1;
+}

lang/m2/comp/input.h

@@ -0,0 +1,18 @@
+/*
+ * (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
+ */
+
+/* I N S T A N T I A T I O N   O F   I N P U T   M O D U L E */
+
+/* $Header$ */
+
+#include	"inputtype.h"
+
+#define INP_NPUSHBACK 2
+#define INP_TYPE	struct f_info
+#define INP_VAR		file_info
+
+#include <inp_pkg.spec>

lang/m2/comp/lookup.c

@@ -0,0 +1,88 @@
+/*
+ * (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
+ */
+
+/* L O O K U P   R O U T I N E S */
+
+/* $Header$ */
+
+#include	"debug.h"
+
+#include	<em_arith.h>
+#include	<em_label.h>
+#include	<assert.h>
+
+#include	"LLlex.h"
+#include	"def.h"
+#include	"idf.h"
+#include	"scope.h"
+#include	"node.h"
+#include	"type.h"
+#include	"misc.h"
+
+struct def *
+lookup(id, scope, import)
+	register struct idf *id;
+	struct scope *scope;
+{
+	/*	Look up a definition of an identifier in scope "scope".
+		Make the "def" list self-organizing.
+		Return a pointer to its "def" structure if it exists,
+		otherwise return 0.
+	*/
+	register struct def *df, *df1;
+
+	/* Look in the chain of definitions of this "id" for one with scope
+	   "scope".
+	*/
+	for (df = id->id_def, df1 = 0;
+	     df && df->df_scope != scope;
+	     df1 = df, df = df->df_next) { /* nothing */ }
+
+	if (df) {
+		/* Found it
+		*/
+		if (df1) {
+			/* Put the definition in front
+			*/
+			df1->df_next = df->df_next;
+			df->df_next = id->id_def;
+			id->id_def = df;
+		}
+		if (import) {
+			while (df->df_kind == D_IMPORT) {
+				assert(df->imp_def != 0);
+				df = df->imp_def;
+			}
+		}
+	}
+	return df;
+}
+
+struct def *
+lookfor(id, vis, give_error)
+	register struct node *id;
+	struct scopelist *vis;
+{
+	/*	Look for an identifier in the visibility range started by "vis".
+		If it is not defined create a dummy definition and,
+		if "give_error" is set, give an error message.
+	*/
+	register struct def *df;
+	register struct scopelist *sc = vis;
+
+	while (sc) {
+		df = lookup(id->nd_IDF, sc->sc_scope, 1);
+		if (df) return df;
+		sc = nextvisible(sc);
+	}
+
+	if (give_error) id_not_declared(id);
+
+	df = MkDef(id->nd_IDF, vis->sc_scope, D_ERROR);
+	df->df_type = error_type;
+	return df;
+}

lang/m2/comp/main.c

@@ -0,0 +1,266 @@
+/*
+ * (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
+ */
+
+/* M A I N   P R O G R A M */
+
+/* $Header$ */
+
+#include	"debug.h"
+
+#include	<system.h>
+#include	<em_arith.h>
+#include	<em_label.h>
+#include	<alloc.h>
+
+#include	"input.h"
+#include	"f_info.h"
+#include	"idf.h"
+#include	"LLlex.h"
+#include	"Lpars.h"
+#include	"type.h"
+#include	"def.h"
+#include	"scope.h"
+#include	"standards.h"
+#include	"tokenname.h"
+#include	"node.h"
+#include	"warning.h"
+#include	"SYSTEM.h"
+
+int		state;			/* either IMPLEMENTATION or PROGRAM */
+char		options[128];
+int		DefinitionModule; 
+char		*ProgName;
+char		**DEFPATH;
+int		nDEF, mDEF;
+int		pass_1;
+struct def 	*Defined;
+extern int 	err_occurred;
+extern int 	Roption;
+extern int	fp_used;		/* set if floating point used */
+struct node	*EmptyStatement;
+
+main(argc, argv)
+	register char **argv;
+{
+	register int Nargc = 1;
+	register char **Nargv = &argv[0];
+
+	ProgName = *argv++;
+	warning_classes = W_INITIAL;
+	DEFPATH = (char **) Malloc(10 * sizeof(char *));
+	mDEF = 10;
+	nDEF = 1;
+
+	while (--argc > 0) {
+		if (**argv == '-')
+			DoOption((*argv++) + 1);
+		else
+			Nargv[Nargc++] = *argv++;
+	}
+	Nargv[Nargc] = 0;	/* terminate the arg vector	*/
+	if (Nargc < 2) {
+		fprint(STDERR, "%s: Use a file argument\n", ProgName);
+		exit(1);
+	}
+	exit(!Compile(Nargv[1], Nargv[2]));
+}
+
+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);
+		return 0;
+	}
+	LineNumber = 1;
+	FileName = src;
+	WorkingDir = getwdir(src);
+	init_idf();
+	InitCst();
+	reserve(tkidf);
+	InitScope();
+	InitTypes();
+	AddStandards();
+	EmptyStatement = dot2leaf(Stat);
+	EmptyStatement->nd_symb = ';';
+	Roption = options['R'];
+#ifdef DEBUG
+	if (options['l']) {
+		LexScan();
+		return 1;
+	}
+#endif DEBUG
+	open_scope(OPENSCOPE);
+	GlobalVis = CurrVis;
+	close_scope(0);
+	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);
+	CheckForLineDirective();
+	pass_1 = 1;
+	CompUnit();
+	C_ms_src((int)LineNumber - 1, FileName);
+	if (!err_occurred) {
+		pass_1 = 0;
+		C_exp(Defined->mod_vis->sc_scope->sc_name);
+		WalkModule(Defined);
+		if (fp_used) C_ms_flt();
+	}
+	C_close();
+#ifdef DEBUG
+	if (options['i']) Info();
+#endif
+	return ! err_occurred;
+}
+
+#ifdef DEBUG
+LexScan()
+{
+	register struct token *tkp = &dot;
+	extern char *symbol2str();
+
+	while (LLlex() > 0) {
+		print(">>> %s ", symbol2str(tkp->tk_symb));
+		switch(tkp->tk_symb) {
+
+		case IDENT:
+			print("%s\n", tkp->TOK_IDF->id_text);
+			break;
+		
+		case INTEGER:
+			print("%ld\n", tkp->TOK_INT);
+			break;
+		
+		case REAL:
+			print("%s\n", tkp->TOK_REL);
+			break;
+
+		case STRING:
+			print("\"%s\"\n", tkp->TOK_STR);
+			break;
+
+		default:
+			print("\n");
+		}
+	}
+}
+#endif
+
+static struct stdproc {
+	char *st_nam;
+	int  st_con;
+} stdproc[] = {
+	{ "ABS",	S_ABS },
+	{ "CAP",	S_CAP },
+	{ "CHR",	S_CHR },
+	{ "FLOAT",	S_FLOAT },
+	{ "HIGH",	S_HIGH },
+	{ "HALT",	S_HALT },
+	{ "EXCL",	S_EXCL },
+	{ "DEC",	S_DEC },
+	{ "INC",	S_INC },
+	{ "VAL",	S_VAL },
+	{ "NEW",	S_NEW },
+	{ "DISPOSE",	S_DISPOSE },
+	{ "TRUNC",	S_TRUNC },
+	{ "SIZE",	S_SIZE },
+	{ "ORD",	S_ORD },
+	{ "ODD",	S_ODD },
+	{ "MAX",	S_MAX },
+	{ "MIN",	S_MIN },
+	{ "INCL",	S_INCL },
+	{ "LONG",	S_LONG },
+	{ "SHORT",	S_SHORT },
+	{ "TRUNCD",	S_TRUNCD },
+	{ "FLOATD",	S_FLOATD },
+	{ 0,		0 }
+};
+
+extern struct def *Enter();
+
+AddStandards()
+{
+	register struct def *df;
+	register struct stdproc *p;
+	static struct token nilconst = { INTEGER, 0};
+
+	for (p = stdproc; p->st_nam != 0; p++) {
+		Enter(p->st_nam, D_PROCEDURE, std_type, p->st_con);
+	}
+
+	EnterType("CHAR", char_type);
+	EnterType("INTEGER", int_type);
+	EnterType("LONGINT", longint_type);
+	EnterType("REAL", real_type);
+	EnterType("LONGREAL", longreal_type);
+	EnterType("BOOLEAN", bool_type);
+	EnterType("CARDINAL", card_type);
+	df = Enter("NIL", D_CONST, address_type, 0);
+	df->con_const = nilconst;
+
+	EnterType("PROC", construct_type(T_PROCEDURE, NULLTYPE));
+	EnterType("BITSET", bitset_type);
+	df = Enter("TRUE", D_ENUM, bool_type, 0);
+	df->enm_val = 1;
+	df->enm_next = Enter("FALSE", D_ENUM, bool_type, 0);
+	df = df->enm_next;
+	df->enm_val = 0;
+	df->enm_next = 0;
+}
+
+do_SYSTEM()
+{
+	/*	Simulate the reading of the SYSTEM definition module
+	*/
+	static char systemtext[] = SYSTEMTEXT;
+
+	open_scope(CLOSEDSCOPE);
+	EnterType("WORD", word_type);
+	EnterType("BYTE", byte_type);
+	EnterType("ADDRESS",address_type);
+	Enter("ADR", D_PROCEDURE, std_type, S_ADR);
+	Enter("TSIZE", D_PROCEDURE, std_type, S_TSIZE);
+	if (!InsertText(systemtext, sizeof(systemtext) - 1)) {
+		fatal("could not insert text");
+	}
+	DefModule();
+	close_scope(SC_CHKFORW);
+}
+
+#ifdef DEBUG
+
+int	cntlines;
+
+Info()
+{
+	extern int cnt_def, cnt_node, cnt_paramlist, cnt_type,
+		   cnt_switch_hdr, cnt_case_entry, 
+		   cnt_scope, cnt_scopelist, cnt_tmpvar;
+
+	print("\
+%6d def\n%6d node\n%6d paramlist\n%6d type\n%6d switch_hdr\n\
+%6d case_entry\n%6d scope\n%6d scopelist\n%6d tmpvar\n",
+cnt_def, cnt_node, cnt_paramlist, cnt_type,
+cnt_switch_hdr, cnt_case_entry, 
+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/main.h

@@ -0,0 +1,25 @@
+/*
+ * (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
+ */
+
+/* S O M E   G L O B A L   V A R I A B L E S */
+
+/* $Header$ */
+
+extern char options[];	/* indicating which options were given */
+
+extern int DefinitionModule;
+			/* flag indicating that we are reading a definition
+			   module
+			*/
+
+extern struct def *Defined;
+			/* definition structure of module defined in this
+			   compilation
+			*/
+extern char **DEFPATH;	/* search path for DEFINITION MODULE's */
+extern int mDEF, nDEF;
+extern int state;	/* either IMPLEMENTATION or PROGRAM */

lang/m2/comp/make.allocd

@@ -0,0 +1,26 @@
+sed -e '
+s:^.*[ 	]ALLOCDEF[ 	].*"\(.*\)"[ 	]*\([0-9][0-9]*\).*$:\
+/* allocation definitions of struct \1 */\
+extern char *st_alloc();\
+extern struct \1 *h_\1;\
+#ifdef DEBUG\
+extern int cnt_\1;\
+extern char *std_alloc();\
+#define	new_\1() ((struct \1 *) std_alloc((char **)\&h_\1, sizeof(struct \1), \2, \&cnt_\1))\
+#else\
+#define	new_\1() ((struct \1 *) st_alloc((char **)\&h_\1, sizeof(struct \1), \2))\
+#endif\
+#define	free_\1(p) st_free(p, \&h_\1, sizeof(struct \1))\
+:' -e '
+s:^.*[ 	]STATICALLOCDEF[ 	].*"\(.*\)"[ 	]*\([0-9][0-9]*\).*$:\
+/* allocation definitions of struct \1 */\
+extern char *st_alloc();\
+struct \1 *h_\1;\
+#ifdef DEBUG\
+int cnt_\1;\
+#define	new_\1() ((struct \1 *) std_alloc((char **)\&h_\1, sizeof(struct \1), \2, \&cnt_\1))\
+#else\
+#define	new_\1() ((struct \1 *) st_alloc((char **)\&h_\1, sizeof(struct \1), \2))\
+#endif\
+#define	free_\1(p) st_free(p, \&h_\1, sizeof(struct \1))\
+:'

lang/m2/comp/make.hfiles

@@ -0,0 +1,35 @@
+: Update Files from database
+
+PATH=/bin:/usr/bin
+
+case $# in
+1) ;;
+*)	echo use: $0 file >&2
+	exit 1
+esac
+
+(
+IFCOMMAND="if (<\$FN) 2>/dev/null;\
+	then	if cmp -s \$FN \$TMP;\
+		then	rm \$TMP;\
+		else	mv \$TMP \$FN;\
+			echo update \$FN;\
+		fi;\
+	else	mv \$TMP \$FN;\
+		echo create \$FN;\
+	fi"
+echo 'TMP=.uf$$'
+echo 'FN=$TMP'
+echo 'cat >$TMP <<\!EOF!'
+sed -n '/^!File:/,${
+/^$/d
+/^!File:[	 ]*\(.*\)$/s@@!EOF!\
+'"$IFCOMMAND"'\
+FN=\1\
+cat >$TMP <<\\!EOF!@
+p
+}' $1
+echo '!EOF!'
+echo $IFCOMMAND
+) |
+sh

lang/m2/comp/make.next

@@ -0,0 +1,7 @@
+echo '#include "debug.h"'
+sed -n '
+s:^.*[ 	]ALLOCDEF[ 	].*"\(.*\)".*$:struct \1 *h_\1 = 0;\
+#ifdef DEBUG\
+int cnt_\1 = 0;\
+#endif:p
+' $*

lang/m2/comp/make.tokcase

@@ -0,0 +1,34 @@
+cat <<'--EOT--'
+#include "Lpars.h"
+
+char *
+symbol2str(tok)
+	int tok;
+{
+	static char buf[2] = { '\0', '\0' };
+
+	if (040 <= tok && tok < 0177) {
+		buf[0] = tok;
+		buf[1] = '\0';
+		return buf;
+	}
+	switch (tok) {
+--EOT--
+sed '
+/{[A-Z]/!d
+s/.*{\(.*\),.*\(".*"\).*$/	case \1 :\
+		return \2;/
+'
+cat <<'--EOT--'
+	case '\n':
+	case '\f':
+	case '\v':
+	case '\r':
+	case '\t':
+		buf[0] = tok;
+		return buf;
+	default:
+		return "bad token";
+	}
+}
+--EOT--

lang/m2/comp/make.tokfile

@@ -0,0 +1,6 @@
+sed '
+/{[A-Z]/!d
+s/.*{//
+s/,.*//
+s/.*/%token	&;/
+'

lang/m2/comp/misc.H

@@ -0,0 +1,16 @@
+/*
+ * (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
+ */
+
+/* M I S C E L L A N E O U S */
+
+/* $Header$ */
+
+#define is_anon_idf(x)		((x)->id_text[0] == '#')
+#define id_not_declared(x)	(not_declared("identifier", (x), ""))
+
+extern struct idf
+	*gen_anon_idf();

lang/m2/comp/misc.c

@@ -0,0 +1,66 @@
+/*
+ * (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
+ */
+
+/* M I S C E L L A N E O U S    R O U T I N E S */
+
+/* $Header$ */
+
+#include	<alloc.h>
+#include	<em_arith.h>
+#include	<em_label.h>
+
+#include	"f_info.h"
+#include	"misc.h"
+#include	"LLlex.h"
+#include	"idf.h"
+#include	"node.h"
+
+match_id(id1, id2)
+	register struct idf *id1, *id2;
+{
+	/*	Check that identifiers id1 and id2 are equal. If they
+		are not, check that we did'nt generate them in the
+		first place, and if not, give an error message
+	*/
+	if (id1 != id2 && !is_anon_idf(id1) && !is_anon_idf(id2)) {
+		error("name \"%s\" does not match block name \"%s\"",
+		      id1->id_text,
+		      id2->id_text
+		);
+	}
+}
+
+struct idf *
+gen_anon_idf()
+{
+	/*	A new idf is created out of nowhere, to serve as an
+		anonymous name.
+	*/
+	static int name_cnt;
+	char buff[100];
+	char *sprint();
+
+	sprint(buff, "#%d in %s, line %u",
+			++name_cnt, FileName, LineNumber);
+	return str2idf(buff, 1);
+}
+
+not_declared(what, id, where)
+	char *what, *where;
+	register struct node *id;
+{
+	/*	The identifier "id" is not declared. If it is not generated,
+		give an error message
+	*/
+	if (!is_anon_idf(id->nd_IDF)) {
+		node_error(id,
+		 	   "%s \"%s\" not declared%s",
+			   what,
+			   id->nd_IDF->id_text,
+			   where);
+	}
+}

lang/m2/comp/modula-2.1

@@ -0,0 +1,100 @@
+.TH MODULA\-2 1ACK
+.ad
+.SH NAME
+Modula-2 \- ACK Modula-2 compiler
+.SH SYNOPSIS
+\fBack\fR \-m\fImach\fR files
+.br
+\fImach\fR files
+.SH INTRODUCTION
+This document provides a short introduction to the use of the ACK Modula-2
+compiler. It also
+tells you where to find definition modules for "standard" modules.
+.SH FILENAMES
+Usually, a Modula-2 program consists of several definition and implementation
+modules, and one program module.
+Definition modules must reside in files with names having a ".def" extension.
+Implementation modules and program modules must reside in files having a
+".mod" extension.
+.PP
+The name of the file in which a definition module is stored must be the same as
+the module-name, apart from the extension.
+Also, in most Unix systems filenames are only 14 characters long.
+So, given an IMPORT declaration for a module called "LongModulName",
+the compiler will try to open a file called "LongModulN.def".
+The requirement does not hold for implementation or program modules,
+but is certainly recommended.
+.SH CALLING THE COMPILER
+The easiest way to do this is to let the \fIack\fR(1) program do it for you.
+So, to compile a program module "prog.mod", just call
+.DS
+\fBack\fR \-m\fImach\fR prog.mod [ objects of implementation modules ]
+	or
+\fImach\fR prog.mod [ objects of implementation modules ]
+.DE
+where \fImach\fR is one of the target machines of ACK.
+.PP
+To compile an implementation module, use the \-\fBc\fR flag
+to produce a ".o" file.
+Definition modules can not be compiled; the compiler reads them when they are
+needed. 
+.PP
+For more details on the \fIack\fR program see \fIack\fR(1).
+.SH DEFINITION MODULES
+"Standard" definition modules can be found in
+the directory \fB~em/lib/m2\fR.
+.PP
+When the compiler needs a definition module, it is first searched for
+in the current directory, then in the directories given to it by the
+\-\fBI\fR flag
+in the order given,
+and then in the directory mentioned above.
+.SH FLAGS
+The \fIack\fR(1) program recognizes (among others) the following
+flags, that are passed to the Modula-2 compiler:
+.IP \fB\-I\fIdirname\fR
+.br
+append \fIdirname\fR to the list of directories where definition modules
+are looked for. 
+.IP \fB\-I\fP
+don't look in
+the directory \fB~em/lib/m2\fR.
+.IP \fB\-M\fP\fIn\fP
+set maximum identifier length to \fIn\fR. The minimum value of \fIn\fR
+is 14, because the keyword "IMPLEMENTATION" is that long.
+.IP \fB\-n\fR
+do not generate EM register messages.
+The user-declared variables will not be stored into registers on the target
+machine.
+.IP \fB\-L\fR
+do not generate the EM \fBfil\fR and \fBlin\fR instructions that enable
+an interpreter to keep track of the current location in the source code.
+.IP \fB\-w\fR\fIclasses\fR
+suppress warning messages whose class is a member of \fIclasses\fR.
+Currently, there are three classes: \fBO\fR, indicating old-flashioned use,
+\fBW\fR, indicating "ordinary" warnings, and \fBR\fR, indicating
+restricted Modula-2.
+If no \fIclasses\fR are given, all warnings are suppressed.
+By default, warnings in class \fBO\fR and \fBW\fR are given.
+.IP \fB\-W\fR\fIclasses\fR
+allow for warning messages whose class is a member of \fIclasses\fR.
+.IP \fB\-x\fR
+make all procedure names global, so that \fIadb\fR(1) understands them.
+.IP \fB\-Xs\fR
+make INTEGER ranges symmetric, t.i., MIN(INTEGER) = - MAX(INTEGER).
+This is useful for interpreters that use the "real" MIN(INTEGER) to
+indicate "undefined".
+.IP \fB\-Xi\fR\fIn\fR
+set maximum number of bits in a set to \fIn\fP.
+When not used, a default value is retained.
+.LP
+.SH SEE ALSO
+\fIack\fR(1), \fIem_m2\fR(6)
+.SH FILES
+.IR ~em/lib/em_m2 :
+binary of the Modula-2 compiler.
+.SH DIAGNOSTICS
+All warning and error messages are written on standard error output.
+.SH REMARKS
+Debugging and profiling facilities may be present during the development
+of \fIem_m2\fP.

lang/m2/comp/nmclash.c

@@ -0,0 +1,4 @@
+/* Accepted if many characters of long names are significant */
+abcdefghijklmnopr() { }
+abcdefghijklmnopq() { }
+main() { }

lang/m2/comp/node.H

@@ -0,0 +1,55 @@
+/*
+ * (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
+ */
+
+/* N O D E   O F   A N   A B S T R A C T   P A R S E T R E E */
+
+/* $Header$ */
+
+struct node {
+	struct node *nd_left;
+	struct node *nd_right;
+	int nd_class;		/* kind of node */
+#define Value	0		/* constant */
+#define Arrsel  1		/* array selection */
+#define Oper	2		/* binary operator */
+#define Uoper	3		/* unary operator */
+#define Arrow	4		/* ^ construction */
+#define Call	5		/* cast or procedure - or function call */
+#define Name	6		/* an identifier */
+#define Set	7		/* a set constant */
+#define Xset	8		/* a set */
+#define Def	9		/* an identified name */
+#define Stat	10		/* a statement */
+#define Link	11
+#define Option	12
+				/* do NOT change the order or the numbers!!! */
+	struct type *nd_type;	/* type of this node */
+	struct token nd_token;
+#define nd_set		nd_token.tk_data.tk_set
+#define nd_def		nd_token.tk_data.tk_def
+#define nd_lab		nd_token.tk_data.tk_lab
+#define nd_symb		nd_token.tk_symb
+#define nd_lineno	nd_token.tk_lineno
+#define nd_IDF		nd_token.TOK_IDF
+#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
+};
+
+/* ALLOCDEF "node" 50 */
+
+extern struct node *MkNode(), *MkLeaf(), *dot2node(), *dot2leaf();
+
+#define NULLNODE ((struct node *) 0)
+
+#define HASSELECTORS	002
+#define VARIABLE	004
+#define VALUE		010
+
+#define	IsCast(lnd)	((lnd)->nd_class == Def && is_type((lnd)->nd_def))
+#define	IsProcCall(lnd)	((lnd)->nd_type->tp_fund == T_PROCEDURE)

lang/m2/comp/node.c

@@ -0,0 +1,117 @@
+/*
+ * (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
+ */
+
+/* N O D E   O F   A N   A B S T R A C T   P A R S E T R E E */
+
+/* $Header$ */
+
+#include	"debug.h"
+
+#include	<em_label.h>
+#include	<em_arith.h>
+#include	<alloc.h>
+#include	<system.h>
+
+#include	"LLlex.h"
+#include	"def.h"
+#include	"type.h"
+#include	"node.h"
+
+struct node *
+MkNode(class, left, right, token)
+	struct node *left, *right;
+	struct token *token;
+{
+	/*	Create a node and initialize it with the given parameters
+	*/
+	register struct node *nd = new_node();
+
+	nd->nd_left = left;
+	nd->nd_right = right;
+	nd->nd_token = *token;
+	nd->nd_class = class;
+	return nd;
+}
+
+struct node *
+dot2node(class, left, right)
+	struct node *left, *right;
+{
+	return MkNode(class, left, right, &dot);
+}
+
+struct node *
+MkLeaf(class, token)
+	struct token *token;
+{
+	register struct node *nd = new_node();
+
+	nd->nd_token = *token;
+	nd->nd_class = class;
+	return nd;
+}
+
+struct node *
+dot2leaf(class)
+{
+	return MkLeaf(class, &dot);
+}
+
+FreeNode(nd)
+	register struct node *nd;
+{
+	/*	Put nodes that are no longer needed back onto the free
+		list
+	*/
+	if (!nd) return;
+	FreeNode(nd->nd_left);
+	FreeNode(nd->nd_right);
+	free_node(nd);
+}
+
+NodeCrash(expp)
+	struct node *expp;
+{
+	crash("Illegal node %d", expp->nd_class);
+}
+
+#ifdef DEBUG
+
+extern char *symbol2str();
+
+indnt(lvl)
+{
+	while (lvl--) {
+		print("  ");
+	}
+}
+
+printnode(nd, lvl)
+	register struct node *nd;
+{
+	indnt(lvl);
+	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)
+	register struct node *nd;
+{
+	if (! nd) {
+		indnt(lvl); print("<nilnode>\n");
+		return;
+	}
+	printnode(nd, lvl);
+	PrNode(nd->nd_left, lvl + 1);
+	PrNode(nd->nd_right, lvl + 1);
+}
+#endif DEBUG

lang/m2/comp/options.c

@@ -0,0 +1,240 @@
+/*
+ * (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
+ */
+
+/* U S E R   O P T I O N - H A N D L I N G */
+
+/* $Header$ */
+
+#include	"idfsize.h"
+
+#include	<em_arith.h>
+#include	<em_label.h>
+#include	<alloc.h>
+
+#include	"type.h"
+#include	"main.h"
+#include	"warning.h"
+
+#define	MINIDFSIZE	14
+
+#if MINIDFSIZE < 14
+You fouled up! MINIDFSIZE has to be at least 14 or the compiler will not
+recognize some keywords!
+#endif
+
+extern int	idfsize;
+static int	ndirs = 1;
+int		warning_classes;
+
+DoOption(text)
+	register char *text;
+{
+	switch(*text++)	{
+
+	case '-':
+		options[*text]++;	/* debug options etc.	*/
+		break;
+
+	case 'L':	/* no fil/lin */
+	case 'R':	/* no range checks */
+	case 'n':	/* no register messages */
+	case 'x':	/* every name global */
+	case 's':	/* symmetric: MIN(INTEGER) = -MAX(INTEGER) */
+		options[text[-1]]++;
+		break;
+
+	case 'i':	/* # of bits in set */
+	{
+		char *t = text;
+		int val;
+		extern int maxset;
+
+		val = txt2int(&t);
+		if (val <= 0 || *t) {
+			error("bad -i flag; use -i<num>");
+		}
+		else	maxset = val;
+		break;
+	}
+	case 'w':
+		if (*text) {
+			while (*text) {
+				switch(*text++) {
+				case 'O':
+					warning_classes &= ~W_OLDFASHIONED;
+					break;
+				case 'R':
+					warning_classes &= ~W_STRICT;
+					break;
+				case 'W':
+					warning_classes &= ~W_ORDINARY;
+					break;
+				}
+			}
+		}
+		else warning_classes = 0;
+		break;
+
+	case 'W':
+		if (*text) {
+			while (*text) {
+				switch(*text++) {
+				case 'O':
+					warning_classes |= W_OLDFASHIONED;
+					break;
+				case 'R':
+					warning_classes |= W_STRICT;
+					break;
+				case 'W':
+					warning_classes |= W_ORDINARY;
+					break;
+				}
+			}
+		}
+		else warning_classes = W_OLDFASHIONED|W_STRICT|W_ORDINARY;
+		break;
+
+	case 'M': {	/* maximum identifier length */
+		char *t = text;		/* because &text is illegal */
+
+		idfsize = txt2int(&t);
+		if (*t || idfsize <= 0)
+			fatal("malformed -M option");
+		if (idfsize > IDFSIZE) {
+			idfsize = IDFSIZE;
+			warning(W_ORDINARY,"maximum identifier length is %d", IDFSIZE);
+		}
+		if (idfsize < MINIDFSIZE) {
+			warning(W_ORDINARY, "minimum identifier length is %d", MINIDFSIZE);
+			idfsize = MINIDFSIZE;
+		}
+		}
+		break;
+
+	case 'I' :
+		if (*text) {
+			register int i;
+			register char *new = text;
+
+			if (++nDEF > mDEF) {
+				char **n = (char **)
+				   Malloc((unsigned)((10+mDEF)*sizeof(char *)));
+
+				for (i = 0; i < mDEF; i++) {
+					n[i] = DEFPATH[i];
+				}
+				free((char *) DEFPATH);
+				DEFPATH = n;
+				mDEF += 10;
+			}
+
+			i = ndirs++;
+			while (new) {
+				register char *tmp = DEFPATH[i];
+	
+				DEFPATH[i++] = new;
+				new = tmp;
+			}
+		}
+		else	DEFPATH[ndirs] = 0;
+		break;
+
+	case 'V' :	/* set object sizes and alignment requirements	*/
+	{
+		register int size;
+		register int align;
+		char c;
+		char *t;
+
+		while (c = *text++)	{
+			char *strindex();
+
+			t = text;
+			size = txt2int(&t);
+			align = 0;
+			if (*(text = t) == '.')	{
+				t = text + 1;
+				align = txt2int(&t);
+				text = t;
+			}
+			if (! strindex("wislfdpS", c)) {
+				error("-V: bad type indicator %c\n", c);
+			}
+			if (size != 0) switch (c)	{
+
+			case 'w':	/* word		*/
+				word_size = size;
+				dword_size = 2 * size;
+				break;
+			case 'i':	/* int		*/
+				int_size = size;
+				break;
+			case 's':	/* short (subranges) */
+				short_size = size;
+				break;
+			case 'l':	/* longint	*/
+				long_size = size;
+				break;
+			case 'f':	/* real		*/
+				float_size = size;
+				break;
+			case 'd':	/* longreal	*/
+				double_size = size;
+				break;
+			case 'p':	/* pointer	*/
+				pointer_size = size;
+				break;
+			}
+			if (align != 0) switch (c)	{
+
+			case 'w':	/* word		*/
+				word_align = align;
+				break;
+			case 'i':	/* int		*/
+				int_align = align;
+				break;
+			case 's':	/* short (subranges) */
+				short_align = align;
+				break;
+			case 'l':	/* longint	*/
+				long_align = align;
+				break;
+			case 'f':	/* real		*/
+				float_align = align;
+				break;
+			case 'd':	/* longreal	*/
+				double_align = align;
+				break;
+			case 'p':	/* pointer	*/
+				pointer_align = align;
+				break;
+			case 'S':	/* initial record alignment	*/
+				struct_align = align;
+				break;
+			}
+		}
+		break;
+	}
+	}
+}
+
+int
+txt2int(tp)
+	register char **tp;
+{
+	/*	the integer pointed to by *tp is read, while increasing
+		*tp; the resulting value is yielded.
+	*/
+	register int val = 0;
+	register int ch;
+	
+	while (ch = **tp, ch >= '0' && ch <= '9')	{
+		val = val * 10 + ch - '0';
+		(*tp)++;
+	}
+	return val;
+}

lang/m2/comp/param.h

@@ -0,0 +1,4 @@
+/* $Header$ */
+
+#define IDFSIZE	256
+#define NUMSIZE 256

lang/m2/comp/print.c

@@ -0,0 +1,144 @@
+/* P R I N T    R O U T I N E S */
+
+#include	<system.h>
+#include	<em_arith.h>
+
+#define SSIZE	1024	/* string-buffer size for print routines	*/
+
+char *long2str();
+
+doprnt(fp, fmt, argp)
+	File *fp;
+	char *fmt;
+	int argp[];
+{
+	char buf[SSIZE];
+
+	sys_write(fp, buf, format(buf, fmt, (char *)argp));
+}
+
+/*VARARGS1*/
+printf(fmt, args)
+	char *fmt;
+	char args;
+{
+	char buf[SSIZE];
+
+	sys_write(STDOUT, buf, format(buf, fmt, &args));
+}
+
+/*VARARGS1*/
+fprintf(fp, fmt, args)
+	File *fp;
+	char *fmt;
+	char args;
+{
+	char buf[SSIZE];
+
+	sys_write(fp, buf, format(buf, fmt, &args));
+}
+
+/*VARARGS1*/
+char *
+sprintf(buf, fmt, args)
+	char *buf, *fmt;
+	char args;
+{
+	buf[format(buf, fmt, &args)] = '\0';
+	return buf;
+}
+
+int
+format(buf, fmt, argp)
+	char *buf, *fmt;
+	char *argp;
+{
+	register char *pf = fmt, *pa = argp;
+	register char *pb = buf;
+
+	while (*pf) {
+		if (*pf == '%') {
+			register int width, base, pad, npad;
+			char *arg;
+			char cbuf[2];
+			char *badformat = "<bad format>";
+			
+			/* get padder */
+			if (*++pf == '0') {
+				pad = '0';
+				++pf;
+			}
+			else
+				pad = ' ';
+			
+			/* get width */
+			width = 0;
+			while (*pf >= '0' && *pf <= '9')
+				width = 10 * width + *pf++ - '0';
+			
+			/* get text and move pa */
+			if (*pf == 's') {
+				arg = *(char **)pa;
+				pa += sizeof(char *);
+			}
+			else
+			if (*pf == 'c') {
+				cbuf[0] = * (char *) pa;
+				cbuf[1] = '\0';
+				pa += sizeof(int);
+				arg = &cbuf[0];
+			}
+			else
+			if (*pf == 'l') {
+				/* alignment ??? */
+				if (base = integral(*++pf)) {
+					arg = long2str(*(long *)pa, base);
+					pa += sizeof(long);
+				}
+				else {
+					pf--;
+					arg = badformat;
+				}
+			}
+			else
+			if (base = integral(*pf)) {
+				arg = long2str((long)*(int *)pa, base);
+				pa += sizeof(int);
+			}
+			else
+			if (*pf == '%')
+				arg = "%";
+			else
+				arg = badformat;
+
+			npad = width - strlen(arg);
+
+			while (npad-- > 0)
+				*pb++ = pad;
+			
+			while (*pb++ = *arg++);
+			pb--;
+			pf++;
+		}
+		else
+			*pb++ = *pf++;
+	}
+	return pb - buf;
+}
+
+integral(c)
+{
+	switch (c) {
+	case 'b':
+		return -2;
+	case 'd':
+		return 10;
+	case 'o':
+		return -8;
+	case 'u':
+		return -10;
+	case 'x':
+		return -16;
+	}
+	return 0;
+}

lang/m2/comp/program.g

@@ -0,0 +1,245 @@
+/*
+ * (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
+ */
+
+/* O V E R A L L   S T R U C T U R E */
+
+/* $Header$ */
+
+{
+#include	"debug.h"
+
+#include	<alloc.h>
+#include	<em_arith.h>
+#include	<em_label.h>
+
+#include	"main.h"
+#include	"idf.h"
+#include	"LLlex.h"
+#include	"scope.h"
+#include	"def.h"
+#include	"type.h"
+#include	"node.h"
+#include	"f_info.h"
+#include	"warning.h"
+
+}
+/*
+	The grammar as given by Wirth is already almost LL(1); the
+	main problem is that the full form of a qualified designator
+	may be:
+		[ module_ident '.' ]* IDENT [ '.' field_ident ]*
+	which is quite confusing to an LL(1) parser. Rather than
+	resorting to context-sensitive techniques, I have decided
+	to render this as:
+		IDENT [ '.' IDENT ]*
+	on the grounds that it is quite natural to consider the first
+	IDENT to be the name of the object and regard the others as
+	field identifiers.
+*/
+
+%lexical LLlex;
+
+%start	CompUnit, CompilationUnit;
+%start	DefModule, DefinitionModule;
+
+ModuleDeclaration
+{
+	register struct def *df;
+	struct node *exportlist = 0;
+	int qualified;
+} :
+	MODULE IDENT	{ df = DefineLocalModule(dot.TOK_IDF); }
+	priority(df)
+	';'
+	import(1)*
+	export(&qualified, &exportlist)?
+	block(&(df->mod_body))
+	IDENT		{ if (exportlist) {
+				EnterExportList(exportlist, qualified);
+			  }
+			  close_scope(SC_CHKFORW|SC_CHKPROC|SC_REVERSE);
+			  match_id(df->df_idf, dot.TOK_IDF);
+			}
+;
+
+priority(register struct def *df;):
+	[
+		'[' ConstExpression(&(df->mod_priority)) ']'
+			{ if (!(df->mod_priority->nd_type->tp_fund &
+				T_CARDINAL)) {
+				node_error(df->mod_priority,
+					   "illegal priority");
+			  }
+			}
+	|
+			{ df->mod_priority = 0; }
+	]
+;
+
+export(int *QUALflag; struct node **ExportList;):
+	EXPORT
+	[
+		QUALIFIED
+			{ *QUALflag = D_QEXPORTED; }
+	|
+			{ *QUALflag = D_EXPORTED; }
+	]
+	IdentList(ExportList) ';'
+;
+
+import(int local;)
+{
+	struct node *ImportList;
+	register struct node *FromId = 0;
+	register struct def *df;
+	extern struct def *GetDefinitionModule();
+} :
+	[ FROM
+	  IDENT		{ FromId = dot2leaf(Name);
+			  if (local) df = lookfor(FromId,enclosing(CurrVis),0);
+			  else df = GetDefinitionModule(dot.TOK_IDF, 1);
+			}
+	]?
+	IMPORT IdentList(&ImportList) ';'
+	/*
+	   When parsing a global module, this is the place where we must
+	   read already compiled definition modules.
+	   If the FROM clause is present, the identifier in it is a module
+	   name, otherwise the names in the import list are module names.
+	*/
+			{ if (FromId) {
+				EnterFromImportList(ImportList, df, FromId);
+			  }
+			  else EnterImportList(ImportList, local);
+			}
+;
+
+DefinitionModule
+{
+	register struct def *df;
+	struct node *exportlist;
+	int dummy;
+	extern struct idf *DefId;
+	extern int ForeignFlag;
+} :
+	DEFINITION
+	MODULE IDENT	{ df = define(dot.TOK_IDF, GlobalScope, D_MODULE);
+			  df->df_flags |= D_BUSY;
+			  df->df_flags |= ForeignFlag;
+			  if (!Defined) Defined = df;
+		  	  CurrentScope->sc_definedby = df;
+			  if (df->df_idf != DefId) {
+				error("DEFINITION MODULE name is \"%s\", not \"%s\"",
+					df->df_idf->id_text, DefId->id_text);
+			  }
+			  CurrentScope->sc_name = df->df_idf->id_text;
+			  df->mod_vis = CurrVis;
+			  df->df_type = standard_type(T_RECORD, 1, (arith) 1);
+			  df->df_type->rec_scope = df->mod_vis->sc_scope;
+			  DefinitionModule++;
+			}
+	';'
+	import(0)* 
+	[
+		export(&dummy, &exportlist)
+		/*	New Modula-2 does not have export lists in definition
+			modules. Issue a warning.
+		*/
+			{ 
+node_warning(exportlist, W_OLDFASHIONED, "export list in definition module ignored");
+				FreeNode(exportlist);
+			}
+	|
+		/* empty */
+	]
+	definition* END IDENT
+			{ register struct def *df1 = CurrentScope->sc_def;
+			  while (df1) {
+				/* Make all definitions "QUALIFIED EXPORT" */
+				df1->df_flags |= D_QEXPORTED;
+				df1 = df1->df_nextinscope;
+			  }
+			  DefinitionModule--;
+			  match_id(df->df_idf, dot.TOK_IDF);
+			  df->df_flags &= ~D_BUSY;
+			}
+	'.'
+;
+
+definition
+{
+	register struct def *df;
+	struct def *dummy;
+} :
+	CONST [ %persistent ConstantDeclaration ';' ]*
+|
+	TYPE
+	[ %persistent
+	  IDENT 	{ df = define(dot.TOK_IDF, CurrentScope, D_TYPE); }
+	  [ '=' type(&(df->df_type))
+	  | /* empty */
+	    /*
+	       Here, the exported type has a hidden implementation.
+	       The export is said to be opaque.
+	       It is restricted to pointer types.
+	    */
+	    		{ df->df_kind = D_HIDDEN;
+			  df->df_type = construct_type(T_HIDDEN, NULLTYPE);
+			}
+	  ]
+	  ';'
+	]*
+|
+	VAR [ %persistent VariableDeclaration ';' ]*
+|
+	ProcedureHeading(&dummy, D_PROCHEAD)
+	';'
+;
+
+ProgramModule
+{
+	extern struct def *GetDefinitionModule();
+	register struct def *df;
+} :
+	MODULE
+	IDENT	{ if (state == IMPLEMENTATION) {
+			df = GetDefinitionModule(dot.TOK_IDF, 0);
+			CurrVis = df->mod_vis;
+			RemoveImports(&(CurrentScope->sc_def));
+		  }
+		  else {
+			Defined = df = define(dot.TOK_IDF, GlobalScope, D_MODULE);
+			open_scope(CLOSEDSCOPE);
+			df->mod_vis = CurrVis;
+			CurrentScope->sc_name = "_M2M";
+		  	CurrentScope->sc_definedby = df;
+		  }
+		}
+	priority(df)
+	';' import(0)*
+	block(&(df->mod_body)) IDENT
+		{ close_scope(SC_CHKFORW|SC_CHKPROC|SC_REVERSE);
+		  match_id(df->df_idf, dot.TOK_IDF);
+		}
+	'.'
+;
+
+Module:
+	DEFINITION
+				{ fatal("Compiling a definition module"); }
+|	%default
+	[
+		IMPLEMENTATION	{ state = IMPLEMENTATION; }
+	|
+		/* empty */	{ state = PROGRAM; }
+	]
+	ProgramModule
+;
+
+CompilationUnit:
+	Module
+;

lang/m2/comp/scope.C

@@ -0,0 +1,238 @@
+/*
+ * (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
+ */
+
+/* S C O P E   M E C H A N I S M */
+
+/* $Header$ */
+
+#include	"debug.h"
+
+#include	<assert.h>
+#include	<alloc.h>
+#include	<em_arith.h>
+#include	<em_label.h>
+
+#include	"LLlex.h"
+#include	"idf.h"
+#include	"scope.h"
+#include	"type.h"
+#include	"def.h"
+#include	"node.h"
+
+struct scope *PervasiveScope;
+struct scopelist *CurrVis, *GlobalVis;
+extern int proclevel;
+static struct scopelist *PervVis;
+extern char options[];
+
+/* STATICALLOCDEF "scope" 10 */
+
+/* STATICALLOCDEF "scopelist" 10 */
+
+open_scope(scopetype)
+{
+	/*	Open a scope that is either open (automatic imports) or closed.
+	*/
+	register struct scope *sc = new_scope();
+	register struct scopelist *ls = new_scopelist();
+	
+	assert(scopetype == OPENSCOPE || scopetype == CLOSEDSCOPE);
+
+	sc->sc_scopeclosed = scopetype == CLOSEDSCOPE;
+	sc->sc_level = proclevel;
+	ls->sc_scope = sc;
+	ls->sc_encl = CurrVis;
+	if (scopetype == OPENSCOPE) {
+		ls->sc_next = ls->sc_encl;
+	}
+	else	ls->sc_next = PervVis;
+	CurrVis = ls;
+}
+
+struct scope *
+open_and_close_scope(scopetype)
+{
+	struct scope *sc;
+
+	open_scope(scopetype);
+	sc = CurrentScope;
+	close_scope(0);
+	return sc;
+}
+
+InitScope()
+{
+	register struct scope *sc = new_scope();
+	register struct scopelist *ls = new_scopelist();
+
+	sc->sc_scopeclosed = 0;
+	sc->sc_def = 0;
+	sc->sc_level = proclevel;
+	PervasiveScope = sc;
+	ls->sc_next = 0;
+	ls->sc_encl = 0;
+	ls->sc_scope = PervasiveScope;
+	PervVis = ls;
+	CurrVis = ls;
+}
+
+STATIC
+chk_proc(df)
+	register struct def *df;
+{
+	/*	Called at scope closing. Check all definitions, and if one
+		is a D_PROCHEAD, the procedure was not defined.
+		Also check that hidden types are defined.
+	*/
+	while (df) {
+		if (df->df_kind == D_HIDDEN) {
+			error("hidden type \"%s\" not declared",
+				df->df_idf->id_text);
+		}
+		else if (df->df_kind == D_PROCHEAD) {
+			/* A not defined procedure
+			*/
+			error("procedure \"%s\" not defined",
+				df->df_idf->id_text);
+			FreeNode(df->for_node);
+		}
+		df = df->df_nextinscope;
+	}
+}
+
+STATIC
+chk_forw(pdf)
+	struct def **pdf;
+{
+	/*	Called at scope close. Look for all forward definitions and
+		if the scope was a closed scope, give an error message for
+		them, and otherwise move them to the enclosing scope.
+	*/
+	register struct def *df;
+
+	while (df = *pdf) {
+		if (df->df_kind == D_FORWTYPE) {
+			register struct def *df1 = df;
+			register struct node *nd = df->df_forw_node;
+
+			*pdf = df->df_nextinscope;
+			RemoveFromIdList(df);
+			df = lookfor(nd, CurrVis, 1);
+			if (! df->df_kind & (D_ERROR|D_FTYPE|D_TYPE)) {
+node_error(nd, "\"%s\" is not a type", df1->df_idf->id_text);
+			}
+			while (nd) {
+				nd->nd_type->tp_next = df->df_type;
+				nd = nd->nd_right;
+			}
+			FreeNode(df1->df_forw_node);
+			free_def(df1);
+			continue;
+		}
+		else if (df->df_kind == D_FTYPE) {
+			register struct node *nd = df->df_forw_node;
+
+			df->df_kind = D_TYPE;
+			while (nd) {
+				nd->nd_type->tp_next = df->df_type;
+				nd = nd->nd_right;
+			}
+			FreeNode(df->df_forw_node);
+		}
+		else if (df->df_kind & (D_FORWARD|D_FORWMODULE)) {
+			/* These definitions must be found in
+			   the enclosing closed scope, which of course
+			   may be the scope that is now closed!
+			*/
+			if (scopeclosed(CurrentScope)) {
+				/* Indeed, the scope was a closed
+				   scope, so give error message
+				*/
+node_error(df->for_node, "identifier \"%s\" not declared",
+df->df_idf->id_text);
+				FreeNode(df->for_node);
+			}
+			else {
+				/* This scope was an open scope.
+				   Maybe the definitions are in the
+				   enclosing scope?
+				*/
+				register struct scopelist *ls =
+						nextvisible(CurrVis);
+				struct def *df1 = df->df_nextinscope;
+	
+				if (df->df_kind == D_FORWMODULE) {
+					df->for_vis->sc_next = ls;
+				}
+				df->df_nextinscope = ls->sc_scope->sc_def;
+				ls->sc_scope->sc_def = df;
+				df->df_scope = ls->sc_scope;
+				*pdf = df1;
+				continue;
+			}
+		}
+		pdf = &df->df_nextinscope;
+	}
+}
+
+Reverse(pdf)
+	struct def **pdf;
+{
+	/*	Reverse the order in the list of definitions in a scope.
+		This is neccesary because this list is built in reverse.
+		Also, while we're at it, remove uninteresting definitions
+		from this list.
+	*/
+	register struct def *df, *df1;
+#define INTERESTING D_MODULE|D_PROCEDURE|D_PROCHEAD|D_VARIABLE
+
+	df = 0;
+	df1 = *pdf;
+
+	while (df1) {
+		if (df1->df_kind & INTERESTING) {
+			struct def *prev = df;
+
+			df = df1;
+			df1 = df1->df_nextinscope;
+			df->df_nextinscope = prev;
+		}
+		else	df1 = df1->df_nextinscope;
+	}
+	*pdf = df;
+}
+
+close_scope(flag)
+	register int flag;
+{
+	/*	Close a scope. If "flag" is set, check for forward declarations,
+		either POINTER declarations, or EXPORTs, or forward references
+		to MODULES
+	*/
+	register struct scope *sc = CurrentScope;
+
+	assert(sc != 0);
+
+	if (flag) {
+		DO_DEBUG(options['S'],(print("List of definitions in currently ended scope:\n"), DumpScope(sc->sc_def)));
+		if (flag & SC_CHKPROC) chk_proc(sc->sc_def);
+		if (flag & SC_CHKFORW) chk_forw(&(sc->sc_def));
+		if (flag & SC_REVERSE) Reverse(&(sc->sc_def));
+	}
+	CurrVis = enclosing(CurrVis);
+}
+
+#ifdef DEBUG
+DumpScope(df)
+	register struct def *df;
+{
+	while (df) {
+		PrDef(df);
+		df = df->df_nextinscope;
+	}
+}
+#endif

lang/m2/comp/scope.h

@@ -0,0 +1,53 @@
+/*
+ * (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
+ */
+
+/* S C O P E   M E C H A N I S M */
+
+/* $Header$ */
+
+#define OPENSCOPE	0	/* Indicating an open scope */
+#define CLOSEDSCOPE	1	/* Indicating a closed scope (module) */
+
+#define SC_CHKFORW	1	/* Check for forward definitions when closing
+				   a scope
+				*/
+#define SC_CHKPROC	2	/* Check for forward procedure definitions
+				   when closing a scope
+				*/
+#define SC_REVERSE	4	/* Reverse list of definitions, to get it
+				   back into original order
+				*/
+
+struct scope {
+	/* struct scope *next; */
+	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 */
+	struct def *sc_definedby; /* The def structure defining this scope */
+};
+
+struct scopelist {
+	struct scopelist *sc_next;
+	struct scope *sc_scope;
+	struct scopelist *sc_encl;
+};
+
+extern struct scope
+	*PervasiveScope;
+
+extern struct scopelist
+	*CurrVis, *GlobalVis;
+
+#define CurrentScope	(CurrVis->sc_scope)
+#define GlobalScope	(GlobalVis->sc_scope)
+#define enclosing(x)	((x)->sc_encl)
+#define scopeclosed(x)	((x)->sc_scopeclosed)
+#define nextvisible(x)	((x)->sc_next)		/* use with scopelists */
+
+struct scope *open_and_close_scope();

lang/m2/comp/standards.h

@@ -0,0 +1,41 @@
+/*
+ * (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
+ */
+
+/* S T A N D A R D   P R O C E D U R E S   A N D   F U N C T I O N S */
+
+/* $Header$ */
+
+#define S_ABS	1
+#define S_CAP	2
+#define S_CHR	3
+#define S_DEC	4
+#define S_EXCL	5
+#define S_FLOAT	6
+#define S_HALT	7
+#define S_HIGH	8
+#define S_INC	9
+#define S_INCL	10
+#define S_MAX	11
+#define S_MIN	12
+#define S_ODD	13
+#define S_ORD	14
+#define S_SIZE	15
+#define S_TRUNC	16
+#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 ... */
+
+#define S_ADR	50
+#define S_TSIZE	51
+#define S_NEWPROCESS	52
+#define S_TRANSFER	53

lang/m2/comp/statement.g

@@ -0,0 +1,295 @@
+/*
+ * (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
+ */
+
+/* S T A T E M E N T S */
+
+/* $Header$ */
+
+{
+#include	<assert.h>
+#include	<em_arith.h>
+#include	<em_label.h>
+
+#include	"idf.h"
+#include	"LLlex.h"
+#include	"scope.h"
+#include	"def.h"
+#include	"type.h"
+#include	"node.h"
+
+static int	loopcount = 0;	/* Count nested loops */
+int		Roption;
+extern char	options[];
+extern struct node *EmptyStatement;
+}
+
+statement(register struct node **pnd;)
+{
+	register struct node *nd;
+	extern int return_occurred;
+} :
+	/* We need some method for making sure lookahead is done, so ...
+	*/
+	[	PROGRAM
+		/* LLlex never returns this */
+	| %default
+				{ if (options['R'] != Roption) {
+					Roption = options['R'];
+					nd = dot2leaf(Option);
+					nd->nd_symb = 'R';
+					nd->nd_INT = Roption;
+					*pnd = nd =
+					    dot2node(Link, nd, NULLNODE);
+					nd->nd_symb = ';';
+					pnd = &(nd->nd_right);
+				  }
+				}
+	]
+[
+	/*
+	 * This part is not in the reference grammar. The reference grammar
+	 * states : assignment | ProcedureCall | ...
+	 * but this gives LL(1) conflicts
+	 */
+	designator(pnd)
+	[			{ nd = dot2node(Call, *pnd, NULLNODE);
+				  nd->nd_symb = '(';
+				}
+		ActualParameters(&(nd->nd_right))?
+	|
+		[ BECOMES	
+		| '='		{ error("':=' expected instead of '='");
+				  DOT = BECOMES;
+				}
+		]
+				{ nd = dot2node(Stat, *pnd, NULLNODE); }
+		expression(&(nd->nd_right))
+	]
+				{ *pnd = nd; }
+	/*
+	 * end of changed part
+	 */
+|
+	IfStatement(pnd)
+|
+	CaseStatement(pnd)
+|
+	WHILE		{ *pnd = nd = dot2leaf(Stat); }
+	expression(&(nd->nd_left))
+	DO
+	StatementSequence(&(nd->nd_right))
+	END
+|
+	REPEAT		{ *pnd = nd = dot2leaf(Stat); }
+	StatementSequence(&(nd->nd_left))
+	UNTIL
+	expression(&(nd->nd_right))
+|
+			{ loopcount++; }
+	LOOP		{ *pnd = nd = dot2leaf(Stat); }
+	StatementSequence(&((*pnd)->nd_right))
+	END
+			{ loopcount--; }
+|
+	ForStatement(pnd)
+|
+	WithStatement(pnd)
+|
+	EXIT
+			{ if (!loopcount) error("EXIT not in a LOOP");
+			  *pnd = dot2leaf(Stat);
+			}
+|
+	ReturnStatement(pnd)
+			{ return_occurred = 1; }
+|
+	/* empty */	{ *pnd = EmptyStatement; }
+]
+;
+
+/*
+ * The next two rules in-line in "Statement", because of an LL(1) conflict
+
+assignment:
+	designator BECOMES expression
+;
+
+ProcedureCall:
+	designator ActualParameters?
+;
+*/
+
+StatementSequence(register struct node **pnd;)
+{
+	struct node *nd;
+	register struct node *nd1;
+} :
+	statement(pnd)
+	[ %persistent
+		';'
+		statement(&nd)
+			{ nd1 = dot2node(Link, *pnd, nd);
+			  *pnd = nd1;
+			  nd1->nd_symb = ';';
+			  pnd = &(nd1->nd_right);
+			}
+	]*
+;
+
+IfStatement(struct node **pnd;)
+{
+	register struct node *nd;
+} :
+	IF		{ nd = dot2leaf(Stat);
+			  *pnd = nd;
+			}
+	expression(&(nd->nd_left))
+	THEN		{ nd->nd_right = dot2leaf(Link);
+			  nd = nd->nd_right;
+			}
+	StatementSequence(&(nd->nd_left))
+	[
+		ELSIF	{ nd->nd_right = dot2leaf(Stat);
+			  nd = nd->nd_right;
+			  nd->nd_symb = IF;
+			}
+		expression(&(nd->nd_left))
+		THEN	{ nd->nd_right = dot2leaf(Link);
+			  nd = nd->nd_right;
+			}
+		StatementSequence(&(nd->nd_left))
+	]*
+	[
+		ELSE
+		StatementSequence(&(nd->nd_right))
+	]?
+	END
+;
+
+CaseStatement(struct node **pnd;)
+{
+	register struct node *nd;
+	struct type *tp = 0;
+} :
+	CASE		{ *pnd = nd = dot2leaf(Stat); }
+	expression(&(nd->nd_left))
+	OF
+	case(&(nd->nd_right), &tp)
+			{ nd = nd->nd_right; }
+	[
+		'|'
+		case(&(nd->nd_right), &tp)
+			{ nd = nd->nd_right; }
+	]*
+	[ ELSE StatementSequence(&(nd->nd_right))
+	]?
+	END
+;
+
+case(struct node **pnd; struct type **ptp;) :
+	[ CaseLabelList(ptp, pnd)
+	  ':'		{ *pnd = dot2node(Link, *pnd, NULLNODE); }
+	  StatementSequence(&((*pnd)->nd_right))
+	]?
+			{ *pnd = dot2node(Link, *pnd, NULLNODE);
+			  (*pnd)->nd_symb = '|';
+			}
+;
+
+/* inline in statement; lack of space 
+WhileStatement(struct node **pnd;)
+{
+	register struct node *nd;
+}:
+	WHILE		{ *pnd = nd = dot2leaf(Stat); }
+	expression(&(nd->nd_left))
+	DO
+	StatementSequence(&(nd->nd_right))
+	END
+;
+
+RepeatStatement(struct node **pnd;)
+{
+	register struct node *nd;
+}:
+	REPEAT		{ *pnd = nd = dot2leaf(Stat); }
+	StatementSequence(&(nd->nd_left))
+	UNTIL
+	expression(&(nd->nd_right))
+;
+*/
+
+ForStatement(struct node **pnd;)
+{
+	register struct node *nd, *nd1;
+	struct node *dummy;
+}:
+	FOR		{ *pnd = nd = dot2leaf(Stat); }
+	IDENT		{ nd->nd_IDF = dot.TOK_IDF; }
+	BECOMES		{ nd->nd_left = nd1 = dot2leaf(Stat); }
+	expression(&(nd1->nd_left))
+	TO
+	expression(&(nd1->nd_right))
+	[
+		BY
+		ConstExpression(&dummy)
+			{ if (!(dummy->nd_type->tp_fund & T_INTORCARD)) {
+				error("illegal type in BY clause");
+			  }
+			  nd1->nd_INT = dummy->nd_INT;
+			  FreeNode(dummy);
+			}
+	|
+			{ nd1->nd_INT = 1; }
+	]
+	DO
+	StatementSequence(&(nd->nd_right))
+	END
+;
+
+/* inline in Statement; lack of space
+LoopStatement(struct node **pnd;):
+	LOOP		{ *pnd = dot2leaf(Stat); }
+	StatementSequence(&((*pnd)->nd_right))
+	END
+;
+*/
+
+WithStatement(struct node **pnd;)
+{
+	register struct node *nd;
+}:
+	WITH		{ *pnd = nd = dot2leaf(Stat); }
+	designator(&(nd->nd_left))
+	DO
+	StatementSequence(&(nd->nd_right))
+	END
+;
+
+ReturnStatement(struct node **pnd;)
+{
+	register struct def *df = CurrentScope->sc_definedby;
+	register struct node *nd;
+} :
+
+	RETURN		{ *pnd = nd = dot2leaf(Stat); }
+	[
+		expression(&(nd->nd_right))
+			{ if (scopeclosed(CurrentScope)) {
+error("a module body has no result value");
+			  }
+			  else if (! ResultType(df->df_type)) {
+error("procedure \"%s\" has no result value", df->df_idf->id_text);
+			  }
+			}
+	|
+			{ if (ResultType(df->df_type)) {
+error("procedure \"%s\" must return a value", df->df_idf->id_text);
+			  }
+			}
+	]
+;

lang/m2/comp/tab.c

@@ -0,0 +1,295 @@
+/*	@cc tab.c -o $INSTALLDIR/tab@
+	tab - table generator 
+
+	Author: Erik Baalbergen (..tjalk!erikb)
+*/
+
+#include <stdio.h> 
+
+static char *RcsId = "$Header$";
+
+#define MAXTAB	10000
+#define MAXBUF	10000
+#define COMCOM	'-'
+#define FILECOM	'%'
+
+int InputForm = 'c';
+char OutputForm[MAXBUF] = "%s,\n";
+int TabSize = 257;
+char *Table[MAXTAB];
+char *Name;
+char *ProgCall;
+
+main(argc, argv)
+	char *argv[];
+{
+	ProgCall = *argv++;
+	argc--;
+	while (argc-- > 0) {
+		if (**argv == COMCOM) {
+			option(*argv++);
+		}
+		else {
+			process(*argv++, InputForm);
+		}
+	}
+}
+
+char *
+Salloc(s)
+	char *s;
+{
+	char *malloc();
+	char *ns = malloc(strlen(s) + 1);
+
+	if (ns) {
+		strcpy(ns, s);
+	}
+	return ns;
+}
+
+option(str)
+	char *str;
+{
+	/*	note that *str indicates the source of the option:
+		either COMCOM (from command line) or FILECOM (from a file).
+	*/
+	switch (*++str) {
+
+	case ' ':	/* command */
+	case '\t':
+	case '\0':
+		break;
+	case 'I':
+		InputForm = *++str;
+		break;
+	case 'f':
+		if (*++str == '\0') {
+			fprintf(stderr, "%s: -f: name expected\n", ProgCall);
+			exit(1);
+		}
+		DoFile(str);
+		break;
+	case 'F':
+		sprintf(OutputForm, "%s\n", ++str);
+		break;
+	case 'T':
+		printf("%s\n", ++str);
+		break;
+	case 'p':
+		PrintTable();
+		break;
+	case 'C':
+		ClearTable();
+		break;
+	case 'S':
+	{
+		register i = stoi(++str);
+
+		if (i <= 0 || i > MAXTAB) {
+			fprintf(stderr, "%s: size would exceed maximum\n",
+				ProgCall);
+		}
+		else {
+			TabSize = i;
+		}
+		break;
+	}
+	default:
+		fprintf(stderr, "%s: bad option -%s\n", ProgCall, str);
+	}
+}
+
+ClearTable()
+{
+	register i;
+
+	for (i = 0; i < MAXTAB; i++) {
+		Table[i] = 0;
+	}
+}
+
+PrintTable()
+{
+	register i;
+
+	for (i = 0; i < TabSize; i++) {
+		if (Table[i]) {
+			printf(OutputForm, Table[i]);
+		}
+		else {
+			printf(OutputForm, "0");
+		}
+	}
+}
+
+process(str, format)
+	char *str;
+{
+	char *cstr = str;
+	char *Name = cstr;	/* overwrite original string!	*/
+
+	/* strip of the entry name
+	*/
+	while (*str && *str != ':') {
+		if (*str == '\\') {
+			++str;
+		}
+		*cstr++ = *str++;
+	}
+
+	if (*str != ':') {
+		fprintf(stderr, "%s: bad specification: \"%s\", ignored\n",
+			ProgCall, Name);
+		return 0;
+	}
+	*cstr = '\0';
+	str++;
+
+	switch (format) {
+
+	case 'c':
+		return c_proc(str, Name);
+	default:
+		fprintf(stderr, "%s: bad input format\n", ProgCall);
+	}
+	return 0;
+}
+
+c_proc(str, Name)
+	char *str;
+	char *Name;
+{
+	int ch, ch2;
+	int quoted();
+
+	while (*str)	{
+		if (*str == '\\')	{
+			ch = quoted(&str);
+		}
+		else	{
+			ch = *str++;
+		}
+		if (*str == '-')	{
+			if (*++str == '\\')	{
+				ch2 = quoted(&str);
+			}
+			else	{
+				if (ch2 = *str++);
+				else str--;
+			}
+			if (ch > ch2)	{
+				fprintf(stderr, "%s: bad range\n", ProgCall);
+				return 0;
+			}
+			if (ch >= 0 && ch2 <= 255)
+				while (ch <= ch2)
+					Table[ch++] = Salloc(Name);
+		}
+		else	{
+			if (ch >= 0 && ch <= 255)
+				Table[ch] = Salloc(Name);
+		}
+	}
+	return 1;
+}
+			
+int
+quoted(pstr)
+	char **pstr;
+{
+	register int ch;
+	register int i;
+	register char *str = *pstr;
+
+	if ((*++str >= '0') && (*str <= '9'))	{
+		ch = 0;
+		for (i = 0; i < 3; i++)	{
+			ch = 8 * ch + *str - '0';
+			if (*++str < '0' || *str > '9')
+				break;
+		}
+	}
+	else	{
+		switch (*str++)	{
+
+		case 'n':
+			ch = '\n';
+			break;
+		case 't':
+			ch = '\t';
+			break;
+		case 'b':
+			ch = '\b';
+			break;
+		case 'r':
+			ch = '\r';
+			break;
+		case 'f':
+			ch = '\f';
+			break;
+		default :
+			ch = *str;
+		}
+	}
+	*pstr = str;
+	return ch & 0377;
+}
+
+int
+stoi(str)
+	char *str;
+{
+	register i = 0;
+
+	while (*str >= '0' && *str <= '9') {
+		i = i * 10 + *str++ - '0';
+	}
+	return i;
+}
+
+char *
+getline(s, n, fp)
+	char *s;
+	FILE *fp;
+{
+	register c = getc(fp);
+	char *str = s;
+
+	while (n--) {
+		if (c == EOF) {
+			return NULL;
+		}
+		else
+		if (c == '\n') {
+			*str++ = '\0';
+			return s;
+		}
+		*str++ = c;
+		c = getc(fp);
+	}
+	s[n - 1] = '\0';
+	return s;
+}
+
+#define BUFSIZE 1024
+
+DoFile(name)
+	char *name;
+{
+	char text[BUFSIZE];
+	FILE *fp;
+
+	if ((fp = fopen(name, "r")) == NULL) {
+		fprintf(stderr, "%s: cannot read file %s\n", ProgCall, name);
+		exit(1);
+	}
+	while (getline(text, BUFSIZE, fp) != NULL) {
+		if (text[0] == FILECOM) {
+			option(text);
+		}
+		else {
+			process(text, InputForm);
+		}
+	}
+}

lang/m2/comp/tmpvar.C

@@ -0,0 +1,137 @@
+/*
+ * (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
+ */
+
+/* T E M P O R A R Y   V A R I A B L E S */
+
+/* $Header$ */
+
+/*	Code for the allocation and de-allocation of temporary variables,
+	allowing re-use.
+	The routines use "ProcScope" instead of "CurrentScope", because
+	"CurrentScope" also reflects WITH statements, and these scopes do not
+	have local variabes.
+*/
+
+#include	"debug.h"
+
+#include	<em_arith.h>
+#include	<em_label.h>
+#include	<em_reg.h>
+#include	<alloc.h>
+#include	<assert.h>
+
+#include	"LLlex.h"
+#include	"def.h"
+#include	"type.h"
+#include	"scope.h"
+#include	"main.h"
+
+struct tmpvar {
+	struct tmpvar	*t_next;
+	arith		t_offset;	/* offset from LocalBase */
+};
+
+/* STATICALLOCDEF "tmpvar" 10 */
+
+static struct tmpvar	*TmpInts,	/* for integer temporaries */
+			*TmpPtrs;	/* for pointer temporaries */
+static struct scope	*ProcScope;	/* scope of procedure in which the
+					   temporaries are allocated
+					*/
+
+TmpOpen(sc) struct scope *sc;
+{
+	/*	Initialize for temporaries in scope "sc".
+	*/
+	ProcScope = sc;
+}
+
+arith
+TmpSpace(sz, al)
+	arith sz;
+{
+	register struct scope *sc = ProcScope;
+
+	sc->sc_off = - WA(align(sz - sc->sc_off, al));
+	return sc->sc_off;
+}
+
+STATIC arith
+NewTmp(plist, sz, al, regtype)
+	struct tmpvar **plist;
+	arith sz;
+{
+	register arith offset;
+	register struct tmpvar *tmp;
+
+	if (!*plist) {
+		offset = TmpSpace(sz, al);
+		if (! options['n']) C_ms_reg(offset, sz, regtype, 0);
+	}
+	else {
+		tmp = *plist;
+		offset = tmp->t_offset;
+		*plist = tmp->t_next;
+		free_tmpvar(tmp);
+	}
+	return offset;
+}
+
+arith
+NewInt()
+{
+	return NewTmp(&TmpInts, int_size, int_align, reg_any);
+}
+
+arith
+NewPtr()
+{
+	return NewTmp(&TmpPtrs, pointer_size, pointer_align, reg_pointer);
+}
+
+STATIC
+FreeTmp(plist, off)
+	struct tmpvar **plist;
+	arith off;
+{
+	register struct tmpvar *tmp = new_tmpvar();
+
+	tmp->t_next = *plist;
+	tmp->t_offset = off;
+	*plist = tmp;
+}
+
+FreeInt(off)
+	arith off;
+{
+	FreeTmp(&TmpInts, off);
+}
+
+FreePtr(off)
+	arith off;
+{
+	FreeTmp(&TmpPtrs, off);
+}
+
+TmpClose()
+{
+	register struct tmpvar *tmp, *tmp1;
+
+	tmp = TmpInts;
+	while (tmp) {
+		tmp1 = tmp;
+		tmp = tmp->t_next;
+		free_tmpvar(tmp1);
+	}
+	tmp = TmpPtrs;
+	while (tmp) {
+		tmp1 = tmp;
+		tmp = tmp->t_next;
+		free_tmpvar(tmp1);
+	}
+	TmpInts = TmpPtrs = 0;
+}

lang/m2/comp/tokenname.c

@@ -0,0 +1,113 @@
+/*
+ * (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
+ */
+
+/* T O K E N   D E F I N I T I O N S */
+
+/* $Header$ */
+
+#include	"tokenname.h"
+#include	"Lpars.h"
+#include	"idf.h"
+
+/*	To centralize the declaration of %tokens, their presence in this
+	file is taken as their declaration. The Makefile will produce
+	a grammar file (tokenfile.g) from this file. This scheme ensures
+	that all tokens have a printable name.
+	Also, the "token2str.c" file is produced from this file.
+*/
+
+#ifdef ___XXX___
+struct tokenname tkspec[] =	{	/* the names of the special tokens */
+	{IDENT, "identifier"},
+	{STRING, "string"},
+	{INTEGER, "number"},
+	{REAL, "real"},
+	{0, ""}
+};
+
+struct tokenname tkcomp[] =	{	/* names of the composite tokens */
+	{LESSEQUAL, "<="},
+	{GREATEREQUAL, ">="},
+	{UPTO, ".."},
+	{BECOMES, ":="},
+	{0, ""}
+};
+#endif
+
+struct tokenname tkidf[] =	{	/* names of the identifier tokens */
+	{AND, "AND"},
+	{ARRAY, "ARRAY"},
+	{BEGIN, "BEGIN"},
+	{BY, "BY"},
+	{CASE, "CASE"},
+	{CONST, "CONST"},
+	{DEFINITION, "DEFINITION"},
+	{DIV, "DIV"},
+	{DO, "DO"},
+	{ELSE, "ELSE"},
+	{ELSIF, "ELSIF"},
+	{END, "END"},
+	{EXIT, "EXIT"},
+	{EXPORT, "EXPORT"},
+	{FOR, "FOR"},
+	{FROM, "FROM"},
+	{IF, "IF"},
+	{IMPLEMENTATION, "IMPLEMENTATION"},
+	{IMPORT, "IMPORT"},
+	{IN, "IN"},
+	{LOOP, "LOOP"},
+	{MOD, "MOD"},
+	{MODULE, "MODULE"},
+	{NOT, "NOT"},
+	{OF, "OF"},
+	{OR, "OR"},
+	{POINTER, "POINTER"},
+	{PROCEDURE, "PROCEDURE"},
+	{QUALIFIED, "QUALIFIED"},
+	{RECORD, "RECORD"},
+	{REPEAT, "REPEAT"},
+	{RETURN, "RETURN"},
+	{SET, "SET"},
+	{THEN, "THEN"},
+	{TO, "TO"},
+	{TYPE, "TYPE"},
+	{UNTIL, "UNTIL"},
+	{VAR, "VAR"},
+	{WHILE, "WHILE"},
+	{WITH, "WITH"},
+	{0, ""}
+};
+
+#ifdef ___XXX___
+struct tokenname tkinternal[] = {	/* internal keywords	*/
+	{PROGRAM, ""},
+	{COERCION, ""},
+	{0, "0"}
+};
+
+struct tokenname tkstandard[] =	{	/* standard identifiers */
+	{0, ""}
+};
+#endif
+
+/* Some routines to handle tokennames */
+
+reserve(resv)
+	register struct tokenname *resv;
+{
+	/*	The names of the tokens described in resv are entered
+		as reserved words.
+	*/
+	register struct idf *p;
+
+	while (resv->tn_symbol)	{
+		p = str2idf(resv->tn_name, 0);
+		if (!p) fatal("out of Memory");
+		p->id_reserved = resv->tn_symbol;
+		resv++;
+	}
+}

lang/m2/comp/tokenname.h

@@ -0,0 +1,17 @@
+/*
+ * (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
+ */
+
+/* T O K E N N A M E   S T R U C T U R E */
+
+/* $Header$ */
+
+struct tokenname	{	/*	Used for defining the name of a
+					token as identified by its symbol
+				*/
+	int tn_symbol;
+	char *tn_name;
+};

lang/m2/comp/type.H

@@ -0,0 +1,185 @@
+/*
+ * (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
+ */
+
+/* T Y P E   D E S C R I P T O R   S T R U C T U R E */
+
+/* $Header$ */
+
+struct paramlist {		/* structure for parameterlist of a PROCEDURE */
+	struct paramlist *par_next;
+	struct def *par_def;	/* "df" of parameter */
+#define	IsVarParam(xpar)	((int) ((xpar)->par_def->df_flags & D_VARPAR))
+#define TypeOfParam(xpar)	((xpar)->par_def->df_type)
+};
+
+/* ALLOCDEF "paramlist" 20 */
+
+struct enume {
+	struct def *en_enums;	/* Definitions of enumeration literals */
+	arith en_ncst;		/* Number of constants */
+	label en_rck;		/* Label of range check descriptor */
+#define enm_enums	tp_value.tp_enum->en_enums
+#define enm_ncst	tp_value.tp_enum->en_ncst
+#define enm_rck		tp_value.tp_enum->en_rck
+};
+
+/* ALLOCDEF "enume" 5 */
+
+struct subrange {
+	arith su_lb, su_ub;	/* lower bound and upper bound */
+	label su_rck;		/* label of range check descriptor */
+#define sub_lb	tp_value.tp_subrange->su_lb
+#define sub_ub	tp_value.tp_subrange->su_ub
+#define sub_rck	tp_value.tp_subrange->su_rck
+};
+
+/* ALLOCDEF "subrange" 5 */
+
+struct array {
+	struct type *ar_elem;	/* type of elements */
+	label ar_descr;		/* label of array descriptor */
+	arith ar_elsize;	/* size of elements */
+#define arr_elem	tp_value.tp_arr->ar_elem
+#define arr_descr	tp_value.tp_arr->ar_descr
+#define arr_elsize	tp_value.tp_arr->ar_elsize
+};
+
+/* ALLOCDEF "array" 5 */
+
+struct record {
+	struct scope *rc_scope;	/* scope of this record */
+				/* members are in the symbol table */
+#define rec_scope	tp_value.tp_record.rc_scope
+};
+
+struct proc {
+	struct paramlist *pr_params;
+	arith pr_nbpar;
+#define prc_params	tp_value.tp_proc.pr_params
+#define prc_nbpar	tp_value.tp_proc.pr_nbpar
+};
+
+struct type	{
+	struct type *tp_next;	/* used with ARRAY, PROCEDURE, POINTER, SET,
+				   SUBRANGE, EQUAL
+				*/
+	int tp_fund;		/* fundamental type  or constructor */
+#define T_RECORD	0x0001
+#define	T_ENUMERATION	0x0002
+#define	T_INTEGER	0x0004
+#define T_CARDINAL	0x0008
+#define T_EQUAL		0x0010
+#define T_REAL		0x0020
+#define T_HIDDEN	0x0040
+#define T_POINTER	0x0080
+#define T_CHAR		0x0100
+#define T_WORD		0x0200
+#define T_SET		0x0400
+#define T_SUBRANGE	0x0800
+#define T_PROCEDURE	0x1000
+#define T_ARRAY		0x2000
+#define T_STRING	0x4000
+#define T_INTORCARD	(T_INTEGER|T_CARDINAL)
+#define T_NUMERIC	(T_INTORCARD|T_REAL)
+#define T_INDEX		(T_ENUMERATION|T_CHAR|T_SUBRANGE)
+#define T_DISCRETE	(T_INDEX|T_INTORCARD)
+#define	T_CONSTRUCTED	(T_ARRAY|T_SET|T_RECORD)
+	int tp_align;		/* alignment requirement of this type */
+	arith tp_size;		/* size of this type */
+	union {
+	    struct enume *tp_enum;
+	    struct subrange *tp_subrange;
+	    struct array *tp_arr;
+	    struct record tp_record;
+	    struct proc tp_proc;
+	} tp_value;
+};
+
+/* ALLOCDEF "type" 50 */
+
+extern struct type
+	*bool_type,
+	*char_type,
+	*int_type,
+	*card_type,
+	*longint_type,
+	*real_type,
+	*longreal_type,
+	*word_type,
+	*byte_type,
+	*address_type,
+	*intorcard_type,
+	*bitset_type,
+	*std_type,
+	*error_type;		/* All from type.c */
+
+extern int
+	word_align,
+	short_align,
+	int_align,
+	long_align,
+	float_align,
+	double_align,
+	pointer_align,
+	struct_align;		/* All from type.c */
+
+extern arith
+	word_size,
+	dword_size,
+	short_size,
+	int_size,
+	long_size,
+	float_size,
+	double_size,
+	pointer_size;		/* All from type.c */
+
+extern arith
+	align();		/* type.c */
+
+struct type
+	*construct_type(),
+	*standard_type(),
+	*set_type(),
+	*subr_type(),
+	*proc_type(),
+	*enum_type(),
+	*qualified_type(),
+	*RemoveEqual();	/* All from type.c */
+
+#define NULLTYPE ((struct type *) 0)
+
+#define IsConformantArray(tpx)	((tpx)->tp_fund==T_ARRAY && (tpx)->tp_size==0)
+#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)->tp_next)
+#define ParamList(tpx)		(assert((tpx)->tp_fund == T_PROCEDURE),\
+					(tpx)->prc_params)
+#define IndexType(tpx)		(assert((tpx)->tp_fund == T_ARRAY),\
+					(tpx)->tp_next)
+#define ElementType(tpx)	(assert((tpx)->tp_fund == T_SET),\
+					(tpx)->tp_next)
+#define PointedtoType(tpx)	(assert((tpx)->tp_fund == T_POINTER),\
+					(tpx)->tp_next)
+#else DEBUG
+#define ResultType(tpx)		((tpx)->tp_next)
+#define ParamList(tpx)		((tpx)->prc_params)
+#define IndexType(tpx)		((tpx)->tp_next)
+#define ElementType(tpx)	((tpx)->tp_next)
+#define PointedtoType(tpx)	((tpx)->tp_next)
+#endif DEBUG
+#define BaseType(tpx)		((tpx)->tp_fund == T_SUBRANGE ? (tpx)->tp_next : \
+					(tpx))
+#define	IsConstructed(tpx)	((tpx)->tp_fund & T_CONSTRUCTED)
+
+extern long full_mask[];
+extern long int_mask[];
+
+#define fit(n, i)	(((n) + ((arith)0x80<<(((i)-1)*8)) & ~full_mask[(i)]) == 0)
+#define ufit(n, i)	(((n) & ~full_mask[(i)]) == 0)

lang/m2/comp/type.c

@@ -0,0 +1,755 @@
+/*
+ * (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
+ */
+
+/*	T Y P E   D E F I N I T I O N   M E C H A N I S M	 */
+
+/* $Header$ */
+
+#include	"target_sizes.h"
+#include	"debug.h"
+#include	"maxset.h"
+
+#include	<assert.h>
+#include	<alloc.h>
+#include	<em_arith.h>
+#include	<em_label.h>
+#include	<em_code.h>
+
+#include	"LLlex.h"
+#include	"def.h"
+#include	"type.h"
+#include	"idf.h"
+#include	"node.h"
+#include	"const.h"
+#include	"scope.h"
+#include	"walk.h"
+#include	"chk_expr.h"
+
+int
+	word_align = AL_WORD,
+	short_align = AL_SHORT,
+	int_align = AL_INT,
+	long_align = AL_LONG,
+	float_align = AL_FLOAT,
+	double_align = AL_DOUBLE,
+	pointer_align = AL_POINTER,
+	struct_align = AL_STRUCT;
+
+int
+	maxset = MAXSET;
+
+arith
+	word_size = SZ_WORD,
+	dword_size = 2 * SZ_WORD,
+	int_size = SZ_INT,
+	short_size = SZ_SHORT,
+	long_size = SZ_LONG,
+	float_size = SZ_FLOAT,
+	double_size = SZ_DOUBLE,
+	pointer_size = SZ_POINTER;
+
+struct type
+	*bool_type,
+	*char_type,
+	*int_type,
+	*card_type,
+	*longint_type,
+	*real_type,
+	*longreal_type,
+	*word_type,
+	*byte_type,
+	*address_type,
+	*intorcard_type,
+	*bitset_type,
+	*std_type,
+	*error_type;
+
+struct type *
+construct_type(fund, tp)
+	int fund;
+	register struct type *tp;
+{
+	/*	fund must be a type constructor.
+		The pointer to the constructed type is returned.
+	*/
+	register struct type *dtp = new_type();
+
+	switch (dtp->tp_fund = fund)	{
+	case T_PROCEDURE:
+	case T_POINTER:
+	case T_HIDDEN:
+		dtp->tp_align = pointer_align;
+		dtp->tp_size = pointer_size;
+		break;
+
+	case T_SET:
+		dtp->tp_align = word_align;
+		break;
+
+	case T_ARRAY:
+		dtp->tp_value.tp_arr = new_array();
+		if (tp) dtp->tp_align = tp->tp_align;
+		break;
+
+	case T_SUBRANGE:
+		assert(tp != 0);
+		dtp->tp_value.tp_subrange = new_subrange();
+		dtp->tp_align = tp->tp_align;
+		dtp->tp_size = tp->tp_size;
+		break;
+
+	default:
+		crash("funny type constructor");
+	}
+
+	dtp->tp_next = tp;
+	return dtp;
+}
+
+arith
+align(pos, al)
+	arith pos;
+	int al;
+{
+	int i = pos % al;
+
+	if (i) return pos + (al - i);
+	return pos;
+}
+
+struct type *
+standard_type(fund, align, size)
+	int fund;
+	int align;
+	arith size;
+{
+	register struct type *tp = new_type();
+
+	tp->tp_fund = fund;
+	tp->tp_align = align;
+	tp->tp_size = size;
+	if (fund == T_ENUMERATION || fund == T_CHAR) {
+		tp->tp_value.tp_enum = new_enume();
+	}
+
+	return tp;
+}
+
+InitTypes()
+{
+	/*	Initialize the predefined types
+	*/
+	register struct type *tp;
+
+	/* first, do some checking
+	*/
+	if ((int) int_size != (int) word_size) {
+		fatal("integer size not equal to word size");
+	}
+
+	if ((int) int_size != (int) pointer_size) {
+		fatal("cardinal size not equal to pointer size");
+	}
+
+	if ((int) long_size < (int) int_size ||
+	    (int) long_size % (int) word_size != 0) {
+		fatal("illegal long integer size");
+	}
+
+	if ((int) double_size < (int) float_size) {
+		fatal("long real size smaller than real size");
+	}
+
+	/* character type
+	*/
+	char_type = standard_type(T_CHAR, 1, (arith) 1);
+	char_type->enm_ncst = 256;
+	
+	/* boolean type
+	*/
+	bool_type = standard_type(T_ENUMERATION, 1, (arith) 1);
+	bool_type->enm_ncst = 2;
+
+	/* integer types, also a "intorcard", for integer constants between
+	   0 and MAX(INTEGER)
+	*/
+	int_type = standard_type(T_INTEGER, int_align, int_size);
+	longint_type = standard_type(T_INTEGER, long_align, long_size);
+	card_type = standard_type(T_CARDINAL, int_align, int_size);
+	intorcard_type = standard_type(T_INTORCARD, int_align, int_size);
+
+	/* floating types
+	*/
+	real_type = standard_type(T_REAL, float_align, float_size);
+	longreal_type = standard_type(T_REAL, double_align, double_size);
+
+	/* SYSTEM types
+	*/
+	word_type = standard_type(T_WORD, word_align, word_size);
+	byte_type = standard_type(T_WORD, 1, (arith) 1);
+	address_type = construct_type(T_POINTER, word_type);
+
+	/* create BITSET type
+	   TYPE BITSET = SET OF [0..W-1];
+	   The subrange is a subrange of type cardinal, because the lower bound
+	   is a non-negative integer (See Rep. 6.3)
+	*/
+	tp = construct_type(T_SUBRANGE, card_type);
+	tp->sub_lb = 0;
+	tp->sub_ub = (int) word_size * 8 - 1;
+	bitset_type = set_type(tp);
+
+	/* a unique type for standard procedures and functions
+	*/
+	std_type = construct_type(T_PROCEDURE, NULLTYPE);
+
+	/* a unique type indicating an error
+	*/
+	error_type = new_type();
+	*error_type = *char_type;
+}
+
+STATIC
+u_small(tp, n)
+	register struct type *tp;
+	arith n;
+{
+	if (ufit(n, 1)) {
+		tp->tp_size = 1;
+		tp->tp_align = 1;
+	}
+	else if (ufit(n, (int)short_size)) {
+		tp->tp_size = short_size;
+		tp->tp_align = short_align;
+	}
+}
+
+struct type *
+enum_type(EnumList)
+	struct node *EnumList;
+{
+	register struct type *tp =
+		standard_type(T_ENUMERATION, int_align, int_size);
+
+	EnterEnumList(EnumList, tp);
+	if (! fit(tp->enm_ncst, (int) int_size)) {
+		node_error(EnumList, "too many enumeration literals");
+	}
+	u_small(tp, (arith) (tp->enm_ncst-1));
+	return tp;
+}
+
+struct type *
+qualified_type(nd)
+	register struct node *nd;
+{
+	register struct def *df;
+
+	if (ChkDesignator(nd)) {
+		if (nd->nd_class != Def) {
+			node_error(nd, "type expected");
+			FreeNode(nd);
+			return error_type;
+		}
+
+		df = nd->nd_def;
+		if (df->df_kind&(D_ISTYPE|D_FORWARD|D_FORWTYPE|D_ERROR)) {
+			if (! df->df_type) {
+node_error(nd,"type \"%s\" not (yet) declared", df->df_idf->id_text);
+				FreeNode(nd);
+				return error_type;
+		    	}
+			FreeNode(nd);
+			if (df->df_kind == D_FORWTYPE) {
+				df->df_kind = D_FTYPE;
+			}
+		   	return df->df_type;
+		}
+node_error(nd,"identifier \"%s\" is not a type", df->df_idf->id_text);
+	}
+	FreeNode(nd);
+	return error_type;
+}
+
+chk_basesubrange(tp, base)
+	register struct type *tp, *base;
+{
+	/*	A subrange had a specified base. Check that the bases conform.
+	*/
+
+	assert(tp->tp_fund == T_SUBRANGE);
+
+	if (base->tp_fund == T_SUBRANGE) {
+		/* Check that the bounds of "tp" fall within the range
+		   of "base".
+		*/
+		int fund = base->tp_next->tp_fund;
+
+		if (! chk_bounds(base->sub_lb, tp->sub_lb, fund) || 
+		    ! chk_bounds(base->sub_ub, tp->sub_ub, fund)) {
+			error("base type has insufficient range");
+		}
+		base = base->tp_next;
+	}
+
+	if (base->tp_fund & (T_ENUMERATION|T_CHAR)) {
+		if (tp->tp_next != base) {
+			error("specified base does not conform");
+		}
+	}
+	else if (base != card_type && base != int_type) {
+		error("illegal base for a subrange");
+	}
+	else if (base == int_type && tp->tp_next == card_type &&
+		 (tp->sub_ub > max_int || tp->sub_ub < 0)) {
+		error("upperbound to large for type INTEGER");
+	}
+	else if (base != tp->tp_next && base != int_type) {
+		error("specified base does not conform");
+	}
+
+	tp->tp_next = base;
+}
+
+int
+chk_bounds(l1, l2, fund)
+	arith l1, l2;
+{
+	/*	compare to arith's, but be careful. They might be unsigned
+	*/
+	if (fund == T_INTEGER) {
+		return l2 >= l1;
+	}
+	return (l2 & mach_long_sign ?
+		(l1 & mach_long_sign ? l2 >= l1 : 1) :
+		(l1 & mach_long_sign ? 0 : l2 >= l1)
+	       );
+}
+
+struct type *
+subr_type(lb, ub)
+	register struct node *lb;
+	struct node *ub;
+{
+	/*	Construct a subrange type from the constant expressions
+		indicated by "lb" and "ub", but first perform some
+		checks
+	*/
+	register struct type *tp = BaseType(lb->nd_type);
+	register struct type *res;
+
+	if (tp == intorcard_type) {
+		/* Lower bound >= 0; in this case, the base type is CARDINAL,
+		   according to the language definition, par. 6.3
+		*/
+		assert(lb->nd_INT >= 0);
+		tp = card_type;
+	}
+
+	if (!ChkCompat(&ub, tp, "subrange bounds")) {
+		return error_type;
+	}
+
+	/* Check base type
+	*/
+	if (! (tp->tp_fund & T_DISCRETE)) {
+		node_error(lb, "illegal base type for subrange");
+		return error_type;
+	}
+
+	/* Check bounds
+	*/
+	if (! chk_bounds(lb->nd_INT, ub->nd_INT, tp->tp_fund)) {
+		node_error(lb, "lower bound exceeds upper bound");
+	}
+
+	/* Now construct resulting type
+	*/
+	res = construct_type(T_SUBRANGE, tp);
+	res->sub_lb = lb->nd_INT;
+	res->sub_ub = ub->nd_INT;
+	if (tp == card_type) {
+		u_small(res, res->sub_ub);
+	}
+	else if (tp == int_type) {
+		if (fit(res->sub_lb, 1) && fit(res->sub_ub, 1)) {
+			res->tp_size = 1;
+			res->tp_align = 1;
+		}
+		else if (fit(res->sub_lb, (int)short_size) &&
+			 fit(res->sub_ub, (int)short_size)) {
+			res->tp_size = short_size;
+			res->tp_align = short_align;
+		}
+	}
+	return res;
+}
+
+struct type *
+proc_type(result_type, parameters, n_bytes_params)
+	struct type *result_type;
+	struct paramlist *parameters;
+	arith n_bytes_params;
+{
+	register struct type *tp = construct_type(T_PROCEDURE, result_type);
+
+	tp->prc_params = parameters;
+	tp->prc_nbpar = n_bytes_params;
+	return tp;
+}
+
+genrck(tp)
+	register struct type *tp;
+{
+	/*	generate a range check descriptor for type "tp" when
+		neccessary. Return its label.
+	*/
+	arith lb, ub;
+	register label ol;
+
+	getbounds(tp, &lb, &ub);
+
+	if (tp->tp_fund == T_SUBRANGE) {
+		if (!(ol = tp->sub_rck)) {
+			tp->sub_rck = ++data_label;
+		}
+	}
+	else if (!(ol = tp->enm_rck)) {
+		tp->enm_rck = ++data_label;
+	}
+	if (!ol) {
+		C_df_dlb(ol = data_label);
+		C_rom_cst(lb);
+		C_rom_cst(ub);
+	}
+	C_lae_dlb(ol, (arith) 0);
+	C_rck(word_size);
+}
+
+getbounds(tp, plo, phi)
+	register struct type *tp;
+	arith *plo, *phi;
+{
+	/*	Get the bounds of a bounded type
+	*/
+
+	assert(bounded(tp));
+
+	if (tp->tp_fund == T_SUBRANGE) {
+		*plo = tp->sub_lb;
+		*phi = tp->sub_ub;
+	}
+	else {
+		*plo = 0;
+		*phi = tp->enm_ncst - 1;
+	}
+}
+
+struct type *
+set_type(tp)
+	register struct type *tp;
+{
+	/*	Construct a set type with base type "tp", but first
+		perform some checks
+	*/
+	arith lb, ub;
+
+	if (! bounded(tp)) {
+		error("illegal base type for set");
+		return error_type;
+	}
+
+	getbounds(tp, &lb, &ub);
+
+	if (lb < 0 || ub > maxset-1 || (sizeof(int)==2 && ub > 65535)) {
+		error("set type limits exceeded");
+		return error_type;
+	}
+
+	tp = construct_type(T_SET, tp);
+	tp->tp_size = WA((ub + 8) >> 3);
+	return tp;
+}
+
+arith
+ArrayElSize(tp)
+	register struct type *tp;
+{
+	/* Align element size to alignment requirement of element type.
+	   Also make sure that its size is either a dividor of the word_size,
+	   or a multiple of it.
+	*/
+	register arith algn;
+
+	if (tp->tp_fund == T_ARRAY) ArraySizes(tp);
+	algn = align(tp->tp_size, tp->tp_align);
+	if (word_size % algn != 0) {
+		/* algn is not a dividor of the word size, so make sure it
+		   is a multiple
+		*/
+		return WA(algn);
+	}
+	return algn;
+}
+
+ArraySizes(tp)
+	register struct type *tp;
+{
+	/*	Assign sizes to an array type, and check index type
+	*/
+	register struct type *index_type = IndexType(tp);
+	register struct type *elem_type = tp->arr_elem;
+	arith lo, hi, diff;
+
+	tp->arr_elsize = ArrayElSize(elem_type);
+	tp->tp_align = elem_type->tp_align;
+
+	/* check index type
+	*/
+	if (! bounded(index_type)) {
+		error("illegal index type");
+		tp->tp_size = tp->arr_elsize;
+		return;
+	}
+
+	getbounds(index_type, &lo, &hi);
+	diff = hi - lo;
+
+	tp->tp_size = (diff + 1) * tp->arr_elsize;
+
+	/* generate descriptor and remember label.
+	*/
+	tp->arr_descr = ++data_label;
+	C_df_dlb(tp->arr_descr);
+	C_rom_cst(lo);
+	C_rom_cst(diff);
+	C_rom_cst(tp->arr_elsize);
+}
+
+FreeType(tp)
+	register struct type *tp;
+{
+	/*	Release type structures indicated by "tp".
+		This procedure is only called for types, constructed with
+		T_PROCEDURE.
+	*/
+	register struct paramlist *pr, *pr1;
+
+	assert(tp->tp_fund == T_PROCEDURE);
+
+	pr = ParamList(tp);
+	while (pr) {
+		pr1 = pr;
+		pr = pr->par_next;
+		free_def(pr1->par_def);
+		free_paramlist(pr1);
+	}
+
+	free_type(tp);
+}
+
+DeclareType(nd, df, tp)
+	register struct def *df;
+	register struct type *tp;
+	struct node *nd;
+{
+	/*	A type with type-description "tp" is declared and must
+		be bound to definition "df".
+		This routine also handles the case that the type-field of
+		"df" is already bound. In that case, it is either an opaque
+		type, or an error message was given when "df" was created.
+	*/
+	register struct type *df_tp = df->df_type;
+
+	if (df_tp && df_tp->tp_fund == T_HIDDEN) {
+	  	if (! (tp->tp_fund & (T_POINTER|T_HIDDEN|T_EQUAL))) {
+			node_error(nd,
+				   "opaque type \"%s\" is not a pointer type",
+				   df->df_idf->id_text);
+		}
+		df_tp->tp_next = tp;
+		df_tp->tp_fund = T_EQUAL;
+		while (tp != df_tp && tp->tp_fund == T_EQUAL) {
+			tp = tp->tp_next;
+		}
+		if (tp == df_tp) {
+			/* Circular definition! */
+			node_error(nd,
+				 "opaque type \"%s\" has a circular definition",
+				 df->df_idf->id_text);
+		}
+	}
+	else	df->df_type = tp;
+}
+
+struct type *
+RemoveEqual(tpx)
+	register struct type *tpx;
+{
+
+	if (tpx) while (tpx->tp_fund == T_EQUAL) tpx = tpx->tp_next;
+	return tpx;
+}
+
+int
+type_or_forward(ptp)
+	struct type **ptp;
+{
+	/*	POINTER TO IDENTIFIER construction. The IDENTIFIER resides
+		in "dot". This routine handles the different cases.
+	*/
+	register struct node *nd;
+	register struct def *df, *df1;
+
+	if ((df1 = lookup(dot.TOK_IDF, CurrentScope, 1))) {
+		/* Either a Module or a Type, but in both cases defined
+		   in this scope, so this is the correct identification
+		*/
+		if (df1->df_kind == D_FORWTYPE) {
+			nd = new_node();
+			nd->nd_token = dot;
+			nd->nd_right = df1->df_forw_node;
+			df1->df_forw_node = nd;
+			nd->nd_type = *ptp;
+		}
+		return 1;
+	}
+	nd = new_node();
+	nd->nd_token = dot;
+	if ((df1 = lookfor(nd, CurrVis, 0))->df_kind == D_MODULE) {
+		/* A Modulename in one of the enclosing scopes.
+		   It is not clear from the language definition that
+		   it is correct to handle these like this, but
+		   existing compilers do it like this, and the
+		   alternative is difficult with a lookahead of only
+		   one token.
+		   ???
+		*/
+		free_node(nd);
+		return 1;
+	}
+	/*	Enter a forward reference into a list belonging to the
+		current scope. This is used for POINTER declarations, which
+		may have forward references that must howewer be declared in the
+		same scope.
+	*/
+	df = define(nd->nd_IDF, CurrentScope, D_FORWTYPE);
+
+	if (df->df_kind == D_TYPE) {
+		(*ptp)->tp_next = df->df_type;
+		free_node(nd);
+		return 0;
+	}
+	nd->nd_type = *ptp;
+	df->df_forw_node = nd;
+	if (df1->df_kind == D_TYPE) {
+		df->df_type = df1->df_type;
+	}
+	return 0;
+}
+
+int
+gcd(m, n)
+	register int m, n;
+{
+	/*	Greatest Common Divisor
+ 	*/
+	register int r;
+
+	while (n)	{
+		r = m % n;
+		m = n;
+		n = r;
+	}
+	return m;
+}
+
+int
+lcm(m, n)
+	int m, n;
+{
+	/*	Least Common Multiple
+ 	*/
+	return m * (n / gcd(m, n));
+}
+
+#ifdef DEBUG
+DumpType(tp)
+	register struct type *tp;
+{
+	if (!tp) return;
+
+	print("align:%d; size:%ld;", tp->tp_align, (long) tp->tp_size);
+
+	print(" fund:");
+	switch(tp->tp_fund) {
+	case T_RECORD:
+		print("RECORD");
+		break;
+	case T_ENUMERATION:
+		print("ENUMERATION; ncst:%d", tp->enm_ncst); break;
+	case T_INTEGER:
+		print("INTEGER"); break;
+	case T_CARDINAL:
+		print("CARDINAL"); break;
+	case T_REAL:
+		print("REAL"); break;
+	case T_HIDDEN:
+		print("HIDDEN"); break;
+	case T_EQUAL:
+		print("EQUAL"); break;
+	case T_POINTER:
+		print("POINTER"); break;
+	case T_CHAR:
+		print("CHAR"); break;
+	case T_WORD:
+		print("WORD"); break;
+	case T_SET:
+		print("SET"); break;
+	case T_SUBRANGE:
+		print("SUBRANGE %ld-%ld", (long) tp->sub_lb, (long) tp->sub_ub);
+		break;
+	case T_PROCEDURE:
+		{
+		register struct paramlist *par = ParamList(tp);
+
+		print("PROCEDURE");
+		if (par) {
+			print("(");
+			while(par) {
+				if (IsVarParam(par)) print("VAR ");
+				DumpType(TypeOfParam(par));
+				par = par->par_next;
+			}
+		}
+		break;
+		}
+	case T_ARRAY:
+		print("ARRAY");
+		print("; element:");
+		DumpType(tp->arr_elem);
+		print("; index:");
+		DumpType(tp->tp_next);
+		print(";");
+		return;
+	case T_STRING:
+		print("STRING"); break;
+	case T_INTORCARD:
+		print("INTORCARD"); break;
+	default:
+		crash("DumpType");
+	}
+	if (tp->tp_next && tp->tp_fund != T_POINTER) {
+		/* Avoid printing recursive types!
+		*/
+		print(" next:(");
+		DumpType(tp->tp_next);
+		print(")");
+	}
+	print(";");
+}
+#endif

lang/m2/comp/typequiv.c

@@ -0,0 +1,298 @@
+/*
+ * (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
+ */
+
+/* T Y P E   E Q U I V A L E N C E */
+
+/* $Header$ */
+
+/*	Routines for testing type equivalence, type compatibility, and
+	assignment compatibility
+*/
+#include	"debug.h"
+
+#include	<em_arith.h>
+#include	<em_label.h>
+#include	<assert.h>
+
+#include	"type.h"
+#include	"LLlex.h"
+#include	"idf.h"
+#include	"def.h"
+#include	"node.h"
+#include	"warning.h"
+
+extern char *sprint();
+
+int
+TstTypeEquiv(tp1, tp2)
+	struct type *tp1, *tp2;
+{
+	/*	test if two types are equivalent.
+	*/
+
+	return     tp1 == tp2
+		||
+		   tp1 == error_type
+		||
+		   tp2 == error_type;
+}
+
+int
+TstParEquiv(tp1, tp2)
+	register struct type *tp1, *tp2;
+{
+	/*	test if two parameter types are equivalent. This routine
+		is used to check if two different procedure declarations
+		(one in the definition module, one in the implementation
+		module) are equivalent. A complication comes from dynamic
+		arrays.
+	*/
+	
+	return
+		   TstTypeEquiv(tp1, tp2)
+		||
+		   (
+		     IsConformantArray(tp1)
+		   &&
+		     IsConformantArray(tp2)
+		   &&
+		     TstTypeEquiv(tp1->arr_elem, tp2->arr_elem)
+		   );
+}
+
+int
+TstProcEquiv(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
+		between procedure variables and procedures.
+	*/
+	register struct paramlist *p1, *p2;
+
+	/* First check if the result types are equivalent
+	*/
+	if (! TstTypeEquiv(ResultType(tp1), ResultType(tp2))) return 0;
+
+	p1 = ParamList(tp1);
+	p2 = ParamList(tp2);
+
+	/* Now check the parameters
+	*/
+	while (p1 && p2) {
+		if (IsVarParam(p1) != IsVarParam(p2) ||
+		    !TstParEquiv(TypeOfParam(p1), TypeOfParam(p2))) return 0;
+		p1 = p1->par_next;
+		p2 = p2->par_next;
+	}
+
+	/* Here, at least one of the parameterlists is exhausted.
+	   Check that they are both.
+	*/
+	return p1 == p2;
+}
+
+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;
+
+	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
+	    ||
+		(  tp2 == intorcard_type
+		&&
+		   (tp1 == int_type || tp1 == card_type || tp1 == address_type)
+		)
+	    ||
+		(  tp2 == address_type
+		&& 
+	          ( tp1 == card_type || tp1->tp_fund == T_POINTER)
+		)
+	;
+}
+
+int
+TstAssCompat(tp1, tp2)
+	register struct type *tp1, *tp2;
+{
+	/*	Test if two types are assignment compatible.
+		See Def 9.1.
+	*/
+	register struct type *tp;
+
+	if (TstCompat(tp1, tp2)) return 1;
+
+	tp1 = BaseType(tp1);
+	tp2 = BaseType(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);
+	}
+
+	if (tp1->tp_fund == T_ARRAY) {
+		/* check for string
+		*/
+		arith size;
+
+		if (IsConformantArray(tp1)) return 0;
+
+		tp = IndexType(tp1);
+		if (tp->tp_fund == T_SUBRANGE) {
+			size = tp->sub_ub - tp->sub_lb + 1;
+		}
+		else	size = tp->enm_ncst;
+	    	tp1 = BaseType(tp1->arr_elem);
+	    	return
+			tp1 == char_type
+		    &&	(tp2->tp_fund  == T_STRING && size >= tp2->tp_size)
+			;
+	}
+
+	return 0;
+}
+
+int
+TstParCompat(parno, formaltype, VARflag, nd, edf)
+	register struct type *formaltype;
+	struct node **nd;
+	struct def *edf;
+{
+	/*	Check type compatibility for a parameter in a procedure call.
+		Assignment compatibility may do if the parameter is
+		a value parameter.
+		Otherwise, a conformant array may do, or an ARRAY OF (WORD|BYTE)
+		may do too.
+		Or: a WORD may do.
+	*/
+	register struct type *actualtype = (*nd)->nd_type;
+	char ebuf[256];
+	char ebuf1[256];
+
+	if (edf) {
+		sprint(ebuf, "\"%s\", parameter %d: %%s", edf->df_idf->id_text, parno);
+	}
+	else sprint(ebuf, "parameter %d: %%s", parno);
+
+	if (
+		TstTypeEquiv(formaltype, actualtype)
+	    ||
+		( !VARflag && ChkAssCompat(nd, formaltype, (char *) 0))
+	    ||
+		(  formaltype == address_type 
+		&& actualtype->tp_fund == T_POINTER
+		)
+	    ||
+		(  formaltype == word_type
+		&& 
+		   (  actualtype->tp_size == word_size
+		   ||
+		      (  !VARflag
+		      &&
+			 actualtype->tp_size <= word_size
+		      )
+		   )
+		)
+	    ||
+		(  formaltype == byte_type
+		&& actualtype->tp_size == (arith) 1
+		)
+	    ||
+		(  IsConformantArray(formaltype)
+		&&
+		   (  formaltype->arr_elem == word_type
+		   || formaltype->arr_elem == byte_type
+		   ||
+		      (  actualtype->tp_fund == T_ARRAY
+		      && TstTypeEquiv(formaltype->arr_elem,actualtype->arr_elem)
+		      )
+		   ||
+		      (  actualtype->tp_fund == T_STRING
+		      && TstTypeEquiv(formaltype->arr_elem, char_type)
+		      )
+		   )
+		)
+	)
+		return 1;
+	if (VARflag && TstCompat(formaltype, actualtype)) {
+		if (formaltype->tp_size == actualtype->tp_size) {
+			sprint(ebuf1, ebuf, "identical types required");
+			node_warning(*nd,
+				     W_OLDFASHIONED,
+				     ebuf1);
+			return 1;
+		}
+		sprint(ebuf1, ebuf, "equal sized types required");
+		node_error(*nd, ebuf1);
+		return 0;
+	}
+				
+	sprint(ebuf1, ebuf, "type incompatibility");
+	node_error(*nd, ebuf1);
+	return 0;
+}
+
+CompatCheck(nd, tp, message, fc)
+	struct node **nd;
+	struct type *tp;
+	char *message;
+	int (*fc)();
+{
+	if (! (*fc)(tp, (*nd)->nd_type)) {
+		if (message) {
+			node_error(*nd, "type incompatibility in %s", message);
+		}
+		return 0;
+	}
+	MkCoercion(nd, tp);
+	return 1;
+}
+
+ChkAssCompat(nd, tp, message)
+	struct node **nd;
+	struct type *tp;
+	char *message;
+{
+	/*	Check assignment compatibility of node "nd" with type "tp".
+		Give an error message when it fails
+	*/
+
+	return CompatCheck(nd, tp, message, TstAssCompat);
+}
+
+ChkCompat(nd, tp, message)
+	struct node **nd;
+	struct type *tp;
+	char *message;
+{
+	/*	Check compatibility of node "nd" with type "tp".
+		Give an error message when it fails
+	*/
+
+	return CompatCheck(nd, tp, message, TstCompat);
+}

lang/m2/comp/walk.c

@@ -0,0 +1,811 @@
+/*
+ * (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
+ */
+
+/* P A R S E   T R E E   W A L K E R */
+
+/* $Header$ */
+
+/*	Routines to walk through parts of the parse tree, and generate
+	code for these parts.
+*/
+
+#include	"debug.h"
+
+#include	<em_arith.h>
+#include	<em_label.h>
+#include	<em_reg.h>
+#include	<em_code.h>
+#include	<m2_traps.h>
+#include	<assert.h>
+#include	<alloc.h>
+
+#include	"LLlex.h"
+#include	"def.h"
+#include	"type.h"
+#include	"scope.h"
+#include	"main.h"
+#include	"node.h"
+#include	"Lpars.h"
+#include	"desig.h"
+#include	"f_info.h"
+#include	"idf.h"
+#include	"chk_expr.h"
+#include	"walk.h"
+#include	"warning.h"
+
+extern arith	NewPtr();
+extern arith	NewInt();
+extern int	proclevel;
+label		text_label;
+label		data_label = 1;
+static struct type *func_type;
+struct withdesig *WithDesigs;
+struct node	*Modules;
+static struct node	*priority;
+
+#define	NO_EXIT_LABEL	((label) 0)
+#define RETURN_LABEL	((label) 1)
+
+STATIC
+DoPriority()
+{
+	/*	For the time being (???), handle priorities by calls to
+		the runtime system
+	*/
+
+	register struct node *p;
+
+	if (p = priority) {
+		C_loc(p->nd_INT);
+		C_cal("_stackprio");
+		C_asp(word_size);
+	}
+}
+
+STATIC
+EndPriority()
+{
+	if (priority) {
+		C_cal("_unstackprio");
+	}
+}
+
+STATIC
+DoProfil()
+{
+	static label	filename_label = 0;
+
+	if (! options['L']) {
+
+		if (! filename_label) {
+			filename_label = 1;
+			C_df_dlb((label) 1);
+			C_rom_scon(FileName, (arith) (strlen(FileName) + 1));
+		}
+
+		C_fil_dlb((label) 1, (arith) 0);
+	}
+}
+
+WalkModule(module)
+	register struct def *module;
+{
+	/*	Walk through a module, and all its local definitions.
+		Also generate code for its body.
+		This code is collected in an initialization routine.
+	*/
+	register struct scope *sc;
+	struct scopelist *savevis = CurrVis;
+
+	CurrVis = module->mod_vis;
+	priority = module->mod_priority;
+	sc = CurrentScope;
+
+	/* Walk through it's local definitions
+	*/
+	WalkDef(sc->sc_def);
+
+	/* Now, generate initialization code for this module.
+	   First call initialization routines for modules defined within
+	   this module.
+	*/
+	sc->sc_off = 0;		/* no locals (yet) */
+	text_label = 1;		/* label at end of initialization routine */
+	TmpOpen(sc);		/* Initialize for temporaries */
+	C_pro_narg(sc->sc_name);
+	DoPriority();
+	DoProfil();
+	if (module == Defined) {
+		/* Body of implementation or program module.
+		   Call initialization routines of imported modules.
+		   Also prevent recursive calls of this one.
+		*/
+		register struct node *nd = Modules;
+
+		if (state == IMPLEMENTATION) {
+			/* We don't actually prevent recursive calls,
+			   but do nothing if called recursively
+			*/
+			C_df_dlb(++data_label);
+			C_con_cst((arith) 0);
+			/* if this one is set to non-zero, the initialization
+			   was already done.
+			*/
+			C_loe_dlb(data_label, (arith) 0);
+			C_zne(RETURN_LABEL);
+			C_ine_dlb(data_label, (arith) 0);
+		}
+
+		for (; nd; nd = nd->nd_left) {
+			C_cal(nd->nd_IDF->id_text);
+		}
+	}
+	MkCalls(sc->sc_def);
+	proclevel++;
+	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);
+	C_end(-sc->sc_off);
+	proclevel--;
+	TmpClose();
+
+	CurrVis = savevis;
+}
+
+WalkProcedure(procedure)
+	register struct def *procedure;
+{
+	/*	Walk through the definition of a procedure and all its
+		local definitions, checking and generating code.
+	*/
+	struct scopelist *savevis = CurrVis;
+	register struct scope *sc = procedure->prc_vis->sc_scope;
+	register struct type *tp;
+	register struct paramlist *param;
+	label func_res_label = 0;
+	arith StackAdjustment = 0;
+	arith retsav = 0;
+	arith func_res_size = 0;
+
+	proclevel++;
+	CurrVis = procedure->prc_vis;
+
+	/* Generate code for all local modules and procedures
+	*/
+	WalkDef(sc->sc_def);
+
+	/* Generate code for this procedure
+	*/
+	C_pro_narg(sc->sc_name);
+	DoPriority();
+	DoProfil();
+	TmpOpen(sc);
+
+	func_type = tp = RemoveEqual(ResultType(procedure->df_type));
+
+	if (tp) {
+		func_res_size = WA(tp->tp_size);
+		if (IsConstructed(tp)) {
+			/* The result type of this procedure is constructed.
+			   The actual procedure will return a pointer to a
+			   global data area in which the function result is
+			   stored.
+			   Notice that this does make the code non-reentrant.
+			   Here, we create the data area for the function
+			   result.
+			*/
+			func_res_label = ++data_label;
+			C_df_dlb(func_res_label);
+			C_bss_cst(func_res_size, (arith) 0, 0);
+		}
+	}
+
+	/* Generate calls to initialization routines of modules defined within
+	   this procedure
+	*/
+	MkCalls(sc->sc_def);
+
+	/* Make sure that arguments of size < word_size are on a
+	   fixed place.
+	   Also make copies of conformant arrays when neccessary.
+	*/
+	for (param = ParamList(procedure->df_type);
+	     param;
+	     param = param->par_next) {
+		if (! IsVarParam(param)) {
+			tp = TypeOfParam(param);
+
+			if (! IsConformantArray(tp)) {
+				if (tp->tp_size < word_size &&
+				    (int) word_size % (int) tp->tp_size == 0) {
+					C_lol(param->par_def->var_off);
+					C_lal(param->par_def->var_off);
+					C_sti(tp->tp_size);
+				}
+			}
+			else {
+				/* Here, we have to make a copy of the
+				   array. We must also remember how much
+				   room is reserved for copies, because
+				   we have to adjust the stack pointer before
+				   a RET is done. This is even more complicated
+				   when the procedure returns a value.
+				   Then, the value must be saved (in retval),
+				   the stack adjusted, the return value pushed
+				   again, and then RET
+				*/
+				if (! StackAdjustment) {
+					/* First time we get here
+					*/
+					if (func_type && !func_res_label) {
+						/* Some local space, only
+						   needed if the value itself
+						   is returned
+						*/
+						sc->sc_off -= func_res_size;
+						retsav = sc->sc_off;
+					}
+					StackAdjustment = NewPtr();
+					C_lor((arith) 1);
+					C_stl(StackAdjustment);
+				}
+				/* First compute new stackpointer */
+				C_lal(param->par_def->var_off);
+				C_cal("_new_stackptr");
+				C_asp(pointer_size);
+				C_lfr(pointer_size);
+				C_str((arith) 1);
+						/* adjusted stack pointer */
+				C_lol(param->par_def->var_off);
+						/* push source address */
+				C_cal("_copy_array");
+						/* copy */
+				C_asp(word_size);
+			}
+		}
+	}
+
+	text_label = 1;		/* label at end of procedure */
+
+	WalkNode(procedure->prc_body, NO_EXIT_LABEL);
+	DO_DEBUG(options['X'], PrNode(procedure->prc_body, 0));
+	if (func_res_size) {
+		C_loc((arith) M2_NORESULT);
+		C_trp();
+		C_asp(-func_res_size);
+	}
+	C_df_ilb(RETURN_LABEL);	/* label at end */
+	if (func_res_label) {
+		/* Fill the data area reserved for the function result
+		   with the result
+		*/
+		C_lae_dlb(func_res_label, (arith) 0);
+		C_sti(func_res_size);
+		if (StackAdjustment) {
+			/* Remove copies of conformant arrays
+			*/
+			C_lol(StackAdjustment);
+			C_str((arith) 1);
+		}
+		C_lae_dlb(func_res_label, (arith) 0);
+		func_res_size = pointer_size;
+	}
+	else if (StackAdjustment) {
+		/* First save the function result in a safe place.
+		   Then remove copies of conformant arrays,
+		   and put function result back on the stack
+		*/
+		if (func_type) {
+			C_lal(retsav);
+			C_sti(func_res_size);
+		}
+		C_lol(StackAdjustment);
+		C_str((arith) 1);
+		if (func_type) {
+			C_lal(retsav);
+			C_loi(func_res_size);
+		}
+		FreePtr(StackAdjustment);
+	}
+	EndPriority();
+	C_ret(func_res_size);
+	if (! options['n']) RegisterMessages(sc->sc_def);
+	C_end(-sc->sc_off);
+	TmpClose();
+	CurrVis = savevis;
+	proclevel--;
+}
+
+WalkDef(df)
+	register struct def *df;
+{
+	/*	Walk through a list of definitions
+	*/
+
+	for ( ; df; df = df->df_nextinscope) {
+		switch(df->df_kind) {
+		case D_MODULE:
+			WalkModule(df);
+			break;
+		case D_PROCEDURE:
+			WalkProcedure(df);
+			break;
+		case D_VARIABLE:
+			if (!proclevel  && !(df->df_flags & D_ADDRGIVEN)) {
+				C_df_dnam(df->var_name);
+				C_bss_cst(
+					WA(df->df_type->tp_size),
+					(arith) 0, 0);
+			}
+			break;
+		default:
+			/* nothing */
+			;
+		}
+	}
+}
+
+MkCalls(df)
+	register struct def *df;
+{
+	/*	Generate calls to initialization routines of modules
+	*/
+
+	for ( ; df; df = df->df_nextinscope) {
+		if (df->df_kind == D_MODULE) {
+			C_lxl((arith) 0);
+			C_cal(df->mod_vis->sc_scope->sc_name);
+			C_asp(pointer_size);
+		}
+	}
+}
+
+WalkLink(nd, exit_label)
+	register struct node *nd;
+	label exit_label;
+{
+	/*	Walk node "nd", which is a link.
+	*/
+
+	while (nd && nd->nd_class == Link) {	 /* statement list */
+		WalkNode(nd->nd_left, exit_label);
+		nd = nd->nd_right;
+	}
+
+	WalkNode(nd, exit_label);
+}
+
+WalkCall(nd)
+	register struct node *nd;
+{
+	assert(nd->nd_class == Call);
+
+	if (! options['L']) C_lin((arith) nd->nd_lineno);
+	if (ChkCall(nd)) {
+		if (nd->nd_type != 0) {
+			node_error(nd, "procedure call expected");
+			return;
+		}
+		CodeCall(nd);
+	}
+}
+
+STATIC
+ForLoopVarExpr(nd)
+	register struct node *nd;
+{
+	register struct type *tp = nd->nd_type;
+
+	CodePExpr(nd);
+	CodeCoercion(tp, BaseType(tp));
+}
+
+WalkStat(nd, exit_label)
+	register struct node *nd;
+	label exit_label;
+{
+	/*	Walk through a statement, generating code for it.
+	*/
+	register struct node *left = nd->nd_left;
+	register struct node *right = nd->nd_right;
+
+	assert(nd->nd_class == Stat);
+
+	if (! options['L'] && nd->nd_lineno) C_lin((arith) nd->nd_lineno);
+	switch(nd->nd_symb) {
+	case ';':
+		break;
+
+	case BECOMES:
+		DoAssign(left, right);
+		break;
+
+	case IF:
+		{	label l1 = ++text_label, l3 = ++text_label;
+
+			ExpectBool(left, l3, l1);
+			assert(right->nd_symb == THEN);
+			C_df_ilb(l3);
+			WalkNode(right->nd_left, exit_label);
+
+			if (right->nd_right) {	/* ELSE part */
+				label l2 = ++text_label;
+
+				C_bra(l2);
+				C_df_ilb(l1);
+				WalkNode(right->nd_right, exit_label);
+				l1 = l2;
+			}
+			C_df_ilb(l1);
+			break;
+		}
+
+	case CASE:
+		CaseCode(nd, exit_label);
+		break;
+
+	case WHILE:
+		{	label	loop = ++text_label,
+				exit = ++text_label,
+				dummy = ++text_label;
+
+			C_df_ilb(loop);
+			ExpectBool(left, dummy, exit);
+			C_df_ilb(dummy);
+			WalkNode(right, exit_label);
+			C_bra(loop);
+			C_df_ilb(exit);
+			break;
+		}
+
+	case REPEAT:
+		{	label loop = ++text_label, exit = ++text_label;
+
+			C_df_ilb(loop);
+			WalkNode(left, exit_label);
+			ExpectBool(right, exit, loop);
+			C_df_ilb(exit);
+			break;
+		}
+
+	case LOOP:
+		{	label loop = ++text_label, exit = ++text_label;
+
+			C_df_ilb(loop);
+			WalkNode(right, exit);
+			C_bra(loop);
+			C_df_ilb(exit);
+			break;
+		}
+
+	case FOR:
+		{
+			arith tmp = 0;
+			register struct node *fnd;
+			int good_forvar;
+			label l1 = ++text_label;
+			label l2 = ++text_label;
+			int uns = 0;
+			arith stepsize;
+			struct type *bstp;
+
+			good_forvar = DoForInit(nd);
+			if ((stepsize = left->nd_INT) == 0) {
+				node_warning(left,
+					     W_ORDINARY,
+					     "zero stepsize in FOR loop");
+			}
+			fnd = left->nd_right;
+			if (good_forvar) {
+				bstp = BaseType(nd->nd_type);
+				uns = bstp->tp_fund != T_INTEGER;
+				C_dup(int_size);
+				RangeCheck(left->nd_left->nd_type, nd->nd_type);
+				CodeDStore(nd);
+				CodePExpr(fnd);
+				tmp = NewInt();
+				C_stl(tmp);
+				C_lol(tmp);
+				if (uns) C_cmu(int_size);
+				else C_cmi(int_size);
+				if (left->nd_INT >= 0) {
+					C_zgt(l2);
+					C_lol(tmp);
+					ForLoopVarExpr(nd);
+				}
+				else {
+					stepsize = -stepsize;
+					C_zlt(l2);
+					ForLoopVarExpr(nd);
+					C_lol(tmp);
+				}
+				C_sbu(int_size);
+				if (stepsize) {
+					C_loc(stepsize);
+					C_dvu(int_size);
+				}
+				C_stl(tmp);
+				nd->nd_def->df_flags |= D_FORLOOP;
+				C_df_ilb(l1);
+			}
+			WalkNode(right, exit_label);
+			nd->nd_def->df_flags &= ~D_FORLOOP;
+			if (good_forvar && stepsize) {	
+				C_lol(tmp);
+				C_zeq(l2);
+				C_lol(tmp);
+				C_loc((arith) 1);
+				C_sbu(int_size);
+				C_stl(tmp);
+				C_loc(left->nd_INT);
+				ForLoopVarExpr(nd);
+				C_adu(int_size);
+				RangeCheck(bstp, nd->nd_type);
+				CodeDStore(nd);
+			}
+			C_bra(l1);
+			C_df_ilb(l2);
+			FreeInt(tmp);
+#ifdef DEBUG
+			nd->nd_left = left;
+			nd->nd_right = right;
+#endif
+		}
+		break;
+
+	case WITH:
+		{
+			struct scopelist link;
+			struct withdesig wds;
+			struct desig ds;
+
+			if (! WalkDesignator(left, &ds)) break;
+			if (left->nd_type->tp_fund != T_RECORD) {
+				node_error(left, "record variable expected");
+				break;
+			}
+
+			wds.w_next = WithDesigs;
+			WithDesigs = &wds;
+			wds.w_scope = left->nd_type->rec_scope;
+			CodeAddress(&ds);
+			ds.dsg_kind = DSG_FIXED;
+			/* Create a designator structure for the temporary.
+			*/
+			ds.dsg_offset = NewPtr();
+			ds.dsg_name = 0;
+			CodeStore(&ds, address_type);
+			ds.dsg_kind = DSG_PFIXED;
+			/* the record is indirectly available */
+			wds.w_desig = ds;
+			link.sc_scope = wds.w_scope;
+			link.sc_next = CurrVis;
+			CurrVis = &link;
+			WalkNode(right, exit_label);
+			CurrVis = link.sc_next;
+			WithDesigs = wds.w_next;
+			FreePtr(ds.dsg_offset);
+			break;
+		}
+
+	case EXIT:
+		assert(exit_label != 0);
+
+		C_bra(exit_label);
+		break;
+
+	case RETURN:
+		if (right) {
+			if (! ChkExpression(right)) break;
+			/* The type of the return-expression must be
+			   assignment compatible with the result type of the
+			   function procedure (See Rep. 9.11).
+			*/
+			if (!ChkAssCompat(&(nd->nd_right), func_type, "RETURN")) {
+				break;
+			}
+			right = nd->nd_right;
+			if (right->nd_type->tp_fund == T_STRING) {
+				CodePString(right, func_type);
+			}
+			else	CodePExpr(right);
+		}
+		C_bra(RETURN_LABEL);
+		break;
+
+	default:
+		crash("(WalkStat)");
+	}
+}
+
+extern int	NodeCrash();
+
+STATIC
+WalkOption(nd)
+	struct node *nd;
+{
+	/* Set option indicated by node "nd"
+	*/
+
+	options[nd->nd_symb] = nd->nd_INT;
+}
+
+int (*WalkTable[])() = {
+	NodeCrash,
+	NodeCrash,
+	NodeCrash,
+	NodeCrash,
+	NodeCrash,
+	WalkCall,
+	NodeCrash,
+	NodeCrash,
+	NodeCrash,
+	NodeCrash,
+	WalkStat,
+	WalkLink,
+	WalkOption
+};
+
+ExpectBool(nd, true_label, false_label)
+	register struct node *nd;
+	label true_label, false_label;
+{
+	/*	"nd" must indicate a boolean expression. Check this and
+		generate code to evaluate the expression.
+	*/
+	register struct desig *ds = new_desig();
+
+	if (ChkExpression(nd)) {
+		if (nd->nd_type != bool_type && nd->nd_type != error_type) {
+			node_error(nd, "boolean expression expected");
+		}
+
+		CodeExpr(nd, ds,  true_label, false_label);
+	}
+	free_desig(ds);
+}
+
+int
+WalkDesignator(nd, ds)
+	struct node *nd;
+	struct desig *ds;
+{
+	/*	Check designator and generate code for it
+	*/
+
+	if (! ChkVariable(nd)) return 0;
+
+	clear((char *) ds, sizeof(struct desig));
+	CodeDesig(nd, ds);
+	return 1;
+}
+
+DoForInit(nd)
+	register struct node *nd;
+{
+	register struct node *left = nd->nd_left;
+	register struct def *df;
+	struct type *tpl, *tpr;
+
+	nd->nd_left = nd->nd_right = 0;
+	nd->nd_class = Name;
+	nd->nd_symb = IDENT;
+
+	if (!( ChkVariable(nd) &
+	       ChkExpression(left->nd_left) &
+	       ChkExpression(left->nd_right))) return 0;
+
+	df = nd->nd_def;
+	if (df->df_kind == D_FIELD) {
+		node_error(nd,
+			   "FOR-loop variable may not be a field of a record");
+		return 1;
+	}
+
+	if (!df->var_name && df->var_off >= 0) {
+		node_error(nd, "FOR-loop variable may not be a parameter");
+		return 1;
+	}
+
+	if (df->df_scope != CurrentScope) {
+		register struct scopelist *sc = CurrVis;
+
+		for (;;) {
+			if (!sc) {
+				node_error(nd,
+				      "FOR-loop variable may not be imported");
+				return 1;
+			}
+			if (sc->sc_scope == df->df_scope) break;
+			sc = nextvisible(sc);
+		}
+	}
+
+	if (df->df_type->tp_size > word_size ||
+	    !(df->df_type->tp_fund & T_DISCRETE)) {
+		node_error(nd, "illegal type of FOR loop variable");
+		return 1;
+	}
+
+	tpl = left->nd_left->nd_type;
+	tpr = left->nd_right->nd_type;
+	if (!ChkAssCompat(&(left->nd_left), df->df_type, "FOR statement") ||
+	    !ChkAssCompat(&(left->nd_right), df->df_type,"FOR statement")) {
+		return 1;
+	}
+	if (!TstCompat(df->df_type, tpl) ||
+	    !TstCompat(df->df_type, tpr)) {
+node_warning(nd, W_OLDFASHIONED, "compatibility required in FOR statement");
+	}
+
+	CodePExpr(left->nd_left);
+	return 1;
+}
+
+DoAssign(left, right)
+	register struct node *left;
+	struct node *right;
+{
+	/* May we do it in this order (expression first) ???
+	   The reference manual sais nothing about it, but the book does:
+	   it sais that the left hand side is evaluated first.
+	   DAMN THE BOOK!
+	*/
+	register struct desig *dsr;
+	register struct type *tp;
+
+	if (! (ChkExpression(right) & ChkVariable(left))) return;
+	tp = left->nd_type;
+
+	if (right->nd_symb == STRING) TryToString(right, tp);
+
+	if (! ChkAssCompat(&right, tp, "assignment")) {
+		return;
+	}
+	dsr = new_desig();
+
+#define StackNeededFor(ds)	((ds)->dsg_kind == DSG_PLOADED \
+				  || (ds)->dsg_kind == DSG_INDEXED)
+	CodeExpr(right, dsr, NO_LABEL, NO_LABEL);
+	tp = right->nd_type;
+	if (complex(tp)) {
+		if (StackNeededFor(dsr)) CodeAddress(dsr);
+	}
+	else {
+		CodeValue(dsr, tp);
+	}
+	CodeMove(dsr, left, tp);
+	free_desig(dsr);
+}
+
+RegisterMessages(df)
+	register struct def *df;
+{
+	register struct type *tp;
+
+	for (; df; df = df->df_nextinscope) {
+		if (df->df_kind == D_VARIABLE && !(df->df_flags & D_NOREG)) {
+			/* Examine type and size
+			*/
+			tp = BaseType(df->df_type);
+			if ((df->df_flags & D_VARPAR) ||
+				 (tp->tp_fund & (T_POINTER|T_HIDDEN|T_EQUAL))) {
+				C_ms_reg(df->var_off, pointer_size,
+					 reg_pointer, 0);
+			}
+			else if (tp->tp_fund & T_NUMERIC) {
+				C_ms_reg(df->var_off,
+					 tp->tp_size,
+					 tp->tp_fund == T_REAL ?
+					    reg_float : reg_any,
+					 0);
+			}
+		}
+	}
+}

lang/m2/comp/walk.h

@@ -0,0 +1,20 @@
+/*
+ * (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
+ */
+
+/* P A R S E   T R E E   W A L K E R */
+
+/* $Header$ */
+
+/*	Definition of WalkNode macro
+*/
+
+extern int (*WalkTable[])();
+
+#define	WalkNode(xnd, xlab)	(*WalkTable[(xnd)->nd_class])((xnd), (xlab))
+
+extern label	text_label;
+extern label	data_label;

lang/m2/comp/warning.h

@@ -0,0 +1,29 @@
+/*
+ * (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
+ */
+
+/* W A R N I N G   C L A S S E S */
+
+/* $Header$ */
+
+/* Warning classes, at the moment three of them:
+   Strict (R)
+   Ordinary (W)
+   Old-fashioned(O)
+*/
+
+/* Bits for a bit mask: */
+
+#define	W_ORDINARY	1
+#define W_STRICT	2
+#define W_OLDFASHIONED	4
+
+#define W_ALL		(W_ORDINARY|W_STRICT|W_OLDFASHIONED)
+
+#define W_INITIAL	(W_ORDINARY | W_OLDFASHIONED)
+
+/* The bit mask itself: */
+extern int	warning_classes;