A newer version, safety commit

lang/m2/comp/LLlex.c

@@ -1,20 +1,23 @@
-/*	LEXICAL ANALYSER FOR MODULA-2	*/
+/* 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 */
 
-#include "input.h"
-#include <alloc.h>
-#include "f_info.h"
-#include "Lpars.h"
-#include "class.h"
-#include "param.h"
-#include "idf.h"
-#include "LLlex.h"
+static char *RcsId = "$Header$";
+
+#include	<alloc.h>
+#include	<em_arith.h>
+#include	"input.h"
+#include	"f_info.h"
+#include	"Lpars.h"
+#include	"class.h"
+#include	"idf.h"
+#include	"LLlex.h"
+
+#define IDFSIZE	256	/* Number of significant characters in an identifier */
+#define NUMSIZE	256	/* maximum number of characters in a number */
 
 long str2long();
 
 struct token dot, aside;
 
-static char *RcsId = "$Header$";
-
 /*	Skip Modula-2 like comment (* ... *).
 	Note that comment may be nested.
 */

lang/m2/comp/LLlex.h

@@ -1,4 +1,4 @@
-/*	Token Descriptor Definition	*/
+/* 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$ */
 
@@ -9,8 +9,8 @@ struct token	{
 		struct idf *tk_idf;	/* IDENT	*/
 		char *tk_str;		/* STRING	*/
 		struct {		/* INTEGER	*/
-			int tk_type;	/* type	*/
-			long tk_value;	/* value	*/
+			struct type *tk_type;	/* type	*/
+			arith tk_value;	/* value	*/
 		} tk_int;
 		char *tk_real;		/* REAL		*/
 	} tk_data;

lang/m2/comp/LLmessage.c

@@ -1,12 +1,15 @@
+/* S Y N T A X   E R R O R   R E P O R T I N G */
+
+static char *RcsId = "$Header$";
+
 #include	<alloc.h>
-#include	"f_info.h"
+#include	<em_arith.h>
 #include	"idf.h"
 #include	"LLlex.h"
 #include	"Lpars.h"
 
-static char *RcsId = "$Header$";
-
 extern char *symbol2str();
+extern struct idf *gen_anon_idf();
 int err_occurred = 0;
 
 LLmessage(tk)
@@ -21,28 +24,6 @@ LLmessage(tk)
 		error("%s deleted", symbol2str(dot.tk_symb));
 }
 
-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 *sprintf();
-
-	sprintf(buff, "#%d in %s, line %u",
-			++name_cnt, FileName, LineNumber);
-	return str2idf(buff, 1);
-}
-
-int
-is_anon_idf(idf)
-	struct idf *idf;
-{
-	return idf->id_text[0] == '#';
-}
-
 insert_token(tk)
 	int tk;
 {

lang/m2/comp/Makefile

@@ -13,7 +13,8 @@ CFLAGS =	-DDEBUG -p $(INCLUDES)
 LFLAGS =	-p
 LOBJ =	tokenfile.o program.o declar.o expression.o statement.o
 COBJ =	LLlex.o LLmessage.o char.o error.o main.o \
-	symbol2str.o tokenname.o idf.o input.o idlist.o
+	symbol2str.o tokenname.o idf.o input.o type.o def.o \
+	scope.o misc.o print.o
 OBJ =	$(COBJ) $(LOBJ) Lpars.o
 GENFILES=	tokenfile.c \
 	program.c declar.c expression.c statement.c \
@@ -40,7 +41,10 @@ tokenfile.g:	tokenname.c make.tokfile
 symbol2str.c:	tokenname.c make.tokcase
 	make.tokcase <tokenname.c >symbol2str.c
 
-idlist.h:	idlist.H make.allocd
+misc.h:		misc.H make.allocd
+def.h:		def.H make.allocd
+type.h:		type.H make.allocd
+scope.c:	scope.C make.allocd
 
 char.c: char.tab tab
 	./tab -fchar.tab >char.c
@@ -61,19 +65,22 @@ depend:
 	make.allocd < $< > $@
 
 #AUTOAUTOAUTOAUTOAUTOAUTOAUTOAUTO
-LLlex.o: LLlex.h Lpars.h class.h f_info.h idf.h param.h
-LLmessage.o: LLlex.h Lpars.h f_info.h idf.h
+LLlex.o: LLlex.h Lpars.h class.h f_info.h idf.h input.h
+LLmessage.o: LLlex.h Lpars.h idf.h
 char.o: class.h
-error.o: LLlex.h f_info.h
-main.o: LLlex.h Lpars.h f_info.h idf.h
+error.o: LLlex.h f_info.h input.h
+main.o: LLlex.h Lpars.h debug.h f_info.h idf.h input.h main.h
 symbol2str.o: Lpars.h
 tokenname.o: Lpars.h idf.h tokenname.h
 idf.o: idf.h
 input.o: f_info.h input.h
-idlist.o: idf.h idlist.h
+type.o: Lpars.h def.h def_sizes.h idf.h type.h
+def.o: Lpars.h def.h idf.h main.h scope.h
+scope.o: scope.h
+misc.o: LLlex.h f_info.h idf.h misc.h
 tokenfile.o: Lpars.h
-program.o: Lpars.h idf.h idlist.h
-declar.o: LLlex.h Lpars.h idf.h idlist.h
+program.o: LLlex.h Lpars.h idf.h main.h misc.h
+declar.o: LLlex.h Lpars.h def.h idf.h misc.h scope.h type.h
 expression.o: Lpars.h
 statement.o: Lpars.h
 Lpars.o: Lpars.h

lang/m2/comp/class.h

@@ -1,4 +1,4 @@
-/*		U S E   O F   C H A R A C T E R   C L A S S E S		*/
+/* U S E   O F   C H A R A C T E R   C L A S S E S */
 
 /* $Header$ */
 

lang/m2/comp/declar.g

@@ -1,17 +1,43 @@
-{
-#include "idf.h"
-#include "idlist.h"
-#include "LLlex.h"
+/* D E C L A R A T I O N S */
 
+{
 static char *RcsId = "$Header$";
+
+#include	<em_arith.h>
+#include	<em_label.h>
+#include	"idf.h"
+#include	"misc.h"
+#include	"LLlex.h"
+#include	"def.h"
+#include	"type.h"
+#include	"scope.h"
 }
 
-ProcedureDeclaration:
-	ProcedureHeading ';' block IDENT
+ProcedureDeclaration
+{
+	register struct def *df;
+} :
+	/* ProcedureHeading(&df) */
+	PROCEDURE IDENT
+			{ df = define(dot.TOK_IDF, CurrentScope, D_PROCEDURE);
+			  open_scope(OPENSCOPE, 0);
+			}
+	FormalParameters?
+	';' block IDENT
+			{ match_id(dot.TOK_IDF, df->df_idf);
+			  close_scope();
+			}
 ;
 
-ProcedureHeading:
-	PROCEDURE IDENT FormalParameters?
+ProcedureHeading
+{
+	register struct def *df;
+} :
+	/*	Only used for definition modules
+	*/
+	PROCEDURE IDENT
+			{ df = define(dot.TOK_IDF, CurrentScope, D_PROCHEAD); }
+	FormalParameters?
 ;
 
 block:
@@ -32,22 +58,34 @@ declaration:
 
 FormalParameters:
 	'(' [ FPSection [ ';' FPSection ]* ]? ')'
-	[ ':' qualident ]?
+	[ ':' qualident
+	]?
 ;
 
 FPSection
 {
 	struct id_list *FPList;
+	int VARflag = 0;
 } :
-	VAR? IdentList(&FPList) ':' FormalType
+	[
+		VAR	{ VARflag = 1; }
+	]?
+	IdentList(&FPList) ':' FormalType
+			{
+			  FreeIdList(FPList);
+			}
 ;
 
 FormalType:
 	[ ARRAY OF ]? qualident
 ;
 
-TypeDeclaration:
-	IDENT '=' type
+TypeDeclaration
+{
+	register struct def *df;
+}:
+	IDENT		{ df = define(dot.TOK_IDF, CurrentScope, D_TYPE); }
+	'=' type
 ;
 
 type:
@@ -169,8 +207,12 @@ FormalTypeList:
 	[ ':' qualident ]?
 ;
 
-ConstantDeclaration:
-	IDENT '=' ConstExpression
+ConstantDeclaration
+{
+	register struct def *df;
+}:
+	IDENT		{ df = define(dot.TOK_IDF, CurrentScope, D_CONST); }
+	'=' ConstExpression
 ;
 
 VariableDeclaration

lang/m2/comp/def.H

@@ -0,0 +1,75 @@
+/* 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 {
+	int mo_priority;	/* Priority of a module */
+};
+
+struct variable {
+	char va_fixedaddress;	/* Flag, set if an address was given */
+	arith va_off;		/* Address or offset of variable */
+};
+
+struct constant {
+	struct expr *co_const;	/* A constant expression */
+};
+
+struct enumval {
+	unsigned int en_val;	/* Value of this enumeration literal */
+	struct def *en_next;	/* Next enumeration literal */
+};
+
+struct field {
+	arith fld_off;
+	struct variant {
+		struct caselabellist *fld_cases;
+		label fld_casedescr;
+		struct def *fld_varianttag;
+	} *fld_variant;
+};
+
+struct import {
+	int im_scopenr;		/* Scope number from which imported */
+};
+
+struct def	{		/* list of definitions for a name */
+	struct def *next;
+	struct idf *df_idf;	/* link back to the name */
+	int df_scope;		/* Scope in which this definition resides */
+	char df_kind;		/* The kind of this definition: */
+#define D_MODULE	0x00
+#define D_PROCEDURE	0x01
+#define D_VARIABLE	0x02
+#define D_FIELD		0x03
+#define D_TYPE		0x04
+#define D_ENUM		0x05
+#define D_CONST		0x06
+#define D_IMPORT	0x07
+#define D_PROCHEAD	0x08	/* A procedure heading in a definition module */
+#define D_HIDDEN	0x09	/* A hidden type */
+#define D_HTYPE		0x0A	/* Definition of a hidden type seen */
+#define D_ISEXPORTED	0xFF	/* Not yet defined */
+	char df_flags;
+#define D_ADDRESS	0x01	/* Set if address was taken */
+#define D_USED		0x02	/* Set if used */
+#define D_DEFINED	0x04	/* Set if it is assigned a value */
+#define D_VARPAR	0x08	/* Set if it is a VAR parameter */
+#define D_EXPORTED	0x40	/* Set if exported */
+#define D_QEXPORTED	0x80	/* Set if qualified exported */
+	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;
+	} df_value;
+};
+
+/* ALLOCDEF "def" */
+
+struct def
+	*define(),
+	*lookup();

lang/m2/comp/def.c

@@ -0,0 +1,83 @@
+/* D E F I N I T I O N   M E C H A N I S M */
+
+static char *RcsId = "$Header$";
+
+#include	<alloc.h>
+#include	<em_arith.h>
+#include	<em_label.h>
+#include	"Lpars.h"
+#include	"def.h"
+#include	"idf.h"
+#include	"main.h"
+#include	"scope.h"
+
+struct def *h_def;		/* Pointer to free list of def structures */
+
+struct def *
+define(id, scope, kind)
+	register struct idf *id;
+	struct scope *scope;
+{
+	/*	Declare an identifier in a scope, but first check if it
+		already has been defined. If so, error message.
+	*/
+	register struct def *df = lookup(id, scope);
+
+	if (df) {
+		switch(df->df_kind) {
+		case D_PROCHEAD:
+			if (kind == D_PROCEDURE) {
+				df->df_kind = D_PROCEDURE;
+				return df;
+			}
+			break;	
+		case D_HIDDEN:
+			if (kind == D_TYPE && state == IMPLEMENTATION) {
+				df->df_kind = D_HTYPE;
+				return df;
+			}
+			break;
+		case D_ISEXPORTED:
+			df->df_kind = kind;
+			return df;
+			break;
+		}
+		error("Identifier %s already declared", id->id_text);
+		return df;
+	}
+	df = new_def();
+	df->df_idf = id;
+	df->df_scope = scope->sc_scope;
+	df->df_kind = kind;
+	df->next = id->id_def;
+	id->id_def = df;
+	return df;
+}
+
+struct def *
+lookup(id, scope)
+	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;
+
+	df1 = 0;
+	df = id->id_def;
+	while (df) {
+		if (df->df_scope == scope->sc_scope) {
+			if (df1) {
+				df1->next = df->next;
+				df->next = id->id_def;
+				id->id_def = df;
+			}
+			return df;
+		}
+		df = df->next;
+	}
+	return 0;
+}

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/error.c

@@ -1,105 +1,101 @@
-/*	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	*/
+/* 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 */
 
 /*	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	<stdio.h>
+static char *RcsId = "$Header$";
+
+#include	<system.h>
+#include	<em_arith.h>
 #include	"input.h"
 #include	"f_info.h"
 #include	"LLlex.h"
 
-static char *RcsId = "$Header$";
-
-#define	ERROUT	stderr
+#define MAXERR_LINE	5	/* Number of error messages on one line ... */
+#define	ERROUT		STDERR
 
+/* error classes */
 #define	ERROR		1
 #define	WARNING		2
 #define	LEXERROR	3
 #define	LEXWARNING	4
 #define	CRASH		5
 #define	FATAL		6
-#define	NONFATAL	7
-#ifdef	DEBUG
-#define	VDEBUG		8
-#endif	DEBUG
+#ifdef DEBUG
+#define VDEBUG		7
+#endif
+
+#define NILEXPR	((struct expr *) 0)
 
 int err_occurred;
-/*
-	extern int ofd;		/* compact.c	* /
-	#define	compiling (ofd >= 0)
-*/
 
+extern char *symbol2str();
 extern char options[];
 
-/*	There are two general error message giving functions:
-	error() : syntactic and semantic error messages
-	lexerror() : lexical and pre-processor error messages
-	The difference lies in the fact that the first function deals with
-	tokens already read in by the lexical analyzer so the name of the
-	file it comes from and the linenumber must be retrieved from the
-	token instead of looking at the global variables LineNumber and
-	FileName.
+/*	There are three general error-message functions:
+		lexerror()	lexical and pre-processor error messages
+		error()		syntactic and semantic error messages
+		expr_error()	errors in expressions
+	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, expression errors get their information from the
+	expression, whereas other errors use the information in the token.
 */
 
+#ifdef DEBUG
+/*VARARGS2*/
+debug(level, fmt, args)
+	char *fmt;
+{
+	if (level <= options['D']) _error(VDEBUG, NILEXPR, fmt, &args);
+}
+#endif DEBUG
+
 /*VARARGS1*/
 error(fmt, args)
 	char *fmt;
 {
-	/*
-		if (compiling)
-			C_ms_err();
-	*/
-	++err_occurred;
-	_error(ERROR, fmt, &args);
+	_error(ERROR, NILEXPR, fmt, &args);
 }
 
-#ifdef DEBUG
-debug(fmt, args)
+/*VARARGS2*/
+expr_error(expr, fmt, args)
+	struct expr *expr;
 	char *fmt;
 {
-	if (options['D'])
-		_error(VDEBUG, fmt, &args);
+	_error(ERROR, expr, fmt, &args);
+}
+
+/*VARARGS1*/
+warning(fmt, args)
+	char *fmt;
+{
+	_error(WARNING, NILEXPR, fmt, &args);
+}
+
+/*VARARGS2*/
+expr_warning(expr, fmt, args)
+	struct expr *expr;
+	char *fmt;
+{
+	_error(WARNING, expr, fmt, &args);
 }
-#endif DEBUG
 
 /*VARARGS1*/
 lexerror(fmt, args)
 	char *fmt;
 {
-	/*
-		if (compiling)
-			C_ms_err();
-	*/
-	++err_occurred;
-	_error(LEXERROR, fmt, &args);
+	_error(LEXERROR, NILEXPR, fmt, &args);
 }
 
 /*VARARGS1*/
-lexwarning(fmt, args) char *fmt;	{
-	if (options['w']) return;
-	_error(LEXWARNING, fmt, &args);
-}
-
-/*VARARGS1*/
-crash(fmt, args)
+lexwarning(fmt, args) 
 	char *fmt;
-	int args;
 {
-	/*
-		if (compiling)
-			C_ms_err();
-	*/
-	_error(CRASH, fmt, &args);
-	fflush(ERROUT);
-	fflush(stderr);
-	fflush(stdout);
-	/*
-		cclose();
-	*/
-	abort();	/* produce core by "Illegal Instruction" */
-			/* this should be changed into exit(1)	 */
+	_error(LEXWARNING, NILEXPR, fmt, &args);
 }
 
 /*VARARGS1*/
@@ -107,64 +103,103 @@ fatal(fmt, args)
 	char *fmt;
 	int args;
 {
-	/*
-		if (compiling)
-			C_ms_err();
-	*/
-	_error(FATAL, fmt, &args);
-	exit(-1);
+
+	_error(FATAL, NILEXPR, fmt, &args);
+	sys_stop(S_EXIT);
 }
 
-/*VARARGS1*/
-nonfatal(fmt, args)
-	char *fmt;
-	int args;
-{
-	_error(NONFATAL, fmt, &args);
-}
-
-/*VARARGS1*/
-warning(fmt, args)
-	char *fmt;
-{
-	if (options['w']) return;
-	_error(WARNING, fmt, &args);
-}
-
-_error(class, fmt, argv)
+_error(class, expr, fmt, argv)
 	int class;
+	struct expr *expr;
 	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;
+	static int e_seen = 0;
+	unsigned int ln = 0;
+	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:
-		fprintf(ERROUT, "%s, line %ld: ", FileName, LineNumber);
+	case CRASH:
+	case FATAL:
+		/*
+		if (C_busy())
+			C_ms_err();
+		*/
+		err_occurred = 1;
 		break;
+	
 	case WARNING:
 	case LEXWARNING:
-		fprintf(ERROUT, "%s, line %ld: (warning) ",
-			FileName, LineNumber);
+		if (options['w'])
+			return;
+		break;
+	}
+
+	/* the remark */
+	switch (class)	{	
+	case WARNING:
+	case LEXWARNING:
+		remark = "(warning)";
 		break;
 	case CRASH:
-		fprintf(ERROUT, "CRASH\007 %s, line %ld: \n",
-			FileName, LineNumber);
+		remark = "CRASH\007";
 		break;
 	case FATAL:
-		fprintf(ERROUT, "%s, line %ld: fatal error -- ",
-			FileName, LineNumber);
+		remark = "fatal error --";
 		break;
-	case NONFATAL:
-		fprintf(ERROUT, "warning: ");	/* no line number ??? */
-		break;
-#ifdef DEBUG
-	case VDEBUG:
-		fprintf(ERROUT, "-D ");
-		break;
-#endif DEBUG
 	}
-	_doprnt(fmt, argv, ERROUT);
+	
+	/* the place */
+	switch (class)	{	
+	case WARNING:
+	case ERROR:
+		ln = /* expr ? expr->ex_line : */ dot.tk_lineno;
+		break;
+	case LEXWARNING:
+	case LEXERROR:
+	case CRASH:
+	case FATAL:
+		ln = LineNumber;
+		break;
+	}
+	
+#ifdef DEBUG
+	if (class != VDEBUG) {
+#endif
+	if (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;
+		e_seen = 0;
+	}
+	
+	if (FileName)
+		fprintf(ERROUT, "\"%s\", line %u: ", FileName, ln);
+	if (remark)
+		fprintf(ERROUT, "%s ", remark);
+#ifdef DEBUG
+	}
+#endif
+	doprnt(ERROUT, fmt, argv);		/* contents of error */
 	fprintf(ERROUT, "\n");
 }

lang/m2/comp/f_info.h

@@ -1,3 +1,5 @@
+/* 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 {

lang/m2/comp/idf.c

@@ -1,3 +1,5 @@
+/* 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"

lang/m2/comp/idf.h

@@ -1,5 +1,14 @@
+/* U S E R   D E C L A R E D   P A R T   O F   I D F */
+
 /* $Header$ */
 
-#define IDF_TYPE int
-#define id_reserved id_user
+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/input.c

@@ -1,3 +1,5 @@
+/* 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"

lang/m2/comp/input.h

@@ -1,3 +1,5 @@
+/* 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$ */
 
 #define INP_NPUSHBACK 2

lang/m2/comp/main.c

@@ -1,18 +1,20 @@
-/* mod2 -- compiler , althans: een aanzet daartoe */
-
-#include <stdio.h>
-#undef BUFSIZ			/* Really neccesary??? */
-#include <system.h>
-#include "input.h"
-#include "f_info.h"
-#include "idf.h"
-#include "LLlex.h"
-#include "Lpars.h"
+/* M A I N   P R O G R A M */
 
 static char *RcsId = "$Header$";
 
+#include	<system.h>
+#include	<em_arith.h>
+#include	"input.h"
+#include	"f_info.h"
+#include	"idf.h"
+#include	"LLlex.h"
+#include	"Lpars.h"
+#include	"main.h"
+#include	"debug.h"
+
 char options[128];
 char *ProgName;
+int state;
 extern int err_occurred;
 
 main(argc, argv)
@@ -23,9 +25,6 @@ main(argc, argv)
 
 	ProgName = *argv++;
 
-# ifdef DEBUG
-	setbuf(stdout, (char *) 0);
-# endif
 	while (--argc > 0) {
 		if (**argv == '-')
 			Option(*argv++);
@@ -34,13 +33,13 @@ main(argc, argv)
 	}
 	Nargv[Nargc] = 0;	/* terminate the arg vector	*/
 	if (Nargc != 2) {
-		fprintf(stderr, "%s: Use one file argument\n", ProgName);
+		fprintf(STDERR, "%s: Use one file argument\n", ProgName);
 		return 1;
 	}
 #ifdef DEBUG
 	printf("Mod2 compiler -- Debug version\n");
-	debug("-D: Debugging on");
 #endif DEBUG
+	DO_DEBUG(debug(1,"Debugging level: %d", options['D']));
 	return !Compile(Nargv[1]);
 }
 
@@ -53,13 +52,15 @@ Compile(src)
 	printf("%s\n", src);
 #endif DEBUG
 	if (! InsertFile(src, (char **) 0)) {
-		fprintf(stderr,"%s: cannot open %s\n", ProgName, src);
+		fprintf(STDERR,"%s: cannot open %s\n", ProgName, src);
 		return 0;
 	}
 	LineNumber = 1;
 	FileName = src;
 	init_idf();
 	reserve(tkidf);
+	init_scope();
+	init_types();
 #ifdef DEBUG
 	if (options['L'])
 		LexScan();
@@ -80,7 +81,7 @@ LexScan()
 {
 	register int symb;
 
-	while ((symb = LLlex()) != EOF) {
+	while ((symb = LLlex()) != EOI) {
 		printf(">>> %s ", symbol2str(symb));
 		switch(symb) {
 
@@ -107,15 +108,12 @@ LexScan()
 }
 
 TimeScan() {
-	while (LLlex() != EOF) /* nothing */;
+	while (LLlex() != -1) /* nothing */;
 }
 #endif
 
 Option(str)
 	char *str;
 {
-#ifdef DEBUG
-	debug("option %c", str[1]);
-#endif DEBUG
 	options[str[1]]++;	/* switch option on	*/
 }

lang/m2/comp/main.h

@@ -0,0 +1,8 @@
+/* S O M E   G L O B A L   V A R I A B L E S */
+
+/* $Header$ */
+
+extern int
+	state;		/* Indicates what we are compiling: A DEFINITION,
+			   an IMPLEMENTATION, or a PROGRAM module
+			*/

lang/m2/comp/misc.H

@@ -0,0 +1,12 @@
+/* M I S C E L L A N E O U S */
+
+/* $Header$ */
+
+/*	Structure to link idf structures together
+*/
+struct id_list {
+	struct id_list *next;
+	struct idf *id_ptr;
+};
+
+/* ALLOCDEF "id_list" */

lang/m2/comp/misc.c

@@ -0,0 +1,63 @@
+/* M I S C E L L A N E O U S    R O U T I N E S */
+
+static char *RcsId = "$Header$";
+
+#include	<alloc.h>
+#include	<em_arith.h>
+#include	"f_info.h"
+#include	"misc.h"
+#include	"LLlex.h"
+#include	"idf.h"
+
+match_id(id1, id2)
+	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("Identifier \"%s\" does not match identifier \"%s\"",
+		      id1->id_text,
+		      id2->id_text
+		);
+	}
+}
+
+struct id_list *h_id_list;	/* Header of free list of id_list structures */
+
+/*	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);
+	}
+}
+
+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 *sprintf();
+
+	sprintf(buff, "#%d in %s, line %u",
+			++name_cnt, FileName, LineNumber);
+	return str2idf(buff, 1);
+}
+
+int
+is_anon_idf(idf)
+	struct idf *idf;
+{
+	return idf->id_text[0] == '#';
+}

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

@@ -1,8 +1,15 @@
-/*
-	Program: Modula-2 grammar in LL(1) form
-	Version: Mon Feb 24 14:29:39 MET 1986
-*/
+/* O V E R A L L   S T R U C T U R E */
 
+{
+static  char *RcsId = "$Header$";
+
+#include	<alloc.h>
+#include	<em_arith.h>
+#include	"idf.h"
+#include	"misc.h"
+#include	"main.h"
+#include	"LLlex.h"
+}
 /*
 	The grammar as given by Wirth is already almost LL(1); the
 	main problem is that the full form of a qualified designator
@@ -17,19 +24,12 @@
 	field identifiers.
 */
 
-{
-#include "idf.h"
-#include "idlist.h"
-
-static  char *RcsId = "$Header$";
-}
-
 %lexical LLlex;
 
 %start	CompUnit, CompilationUnit;
 
 ModuleDeclaration:
-	MODULE IDENT priority? ';' import* export? block IDENT
+	MODULE IDENT priority? ';' import(1)* export? block IDENT
 ;
 
 priority:
@@ -41,14 +41,18 @@ export
 	struct id_list *ExportList;
 } :
 	EXPORT QUALIFIED? IdentList(&ExportList) ';'
+			{
+			  FreeIdList(ExportList);
+			}
 ;
 
-import
+import(int local;)
 {
 	struct id_list *ImportList;
+	struct idf *id = 0;
 } :
 	[ FROM
-	  IDENT
+	  IDENT		{ id = dot.TOK_IDF; }
 	]?
 	IMPORT IdentList(&ImportList) ';'
 	/*
@@ -57,19 +61,19 @@ import
 	   If the FROM clause is present, the identifier in it is a module
 	   name, otherwise the names in the import list are module names.
 	*/
+			{
+			  FreeIdList(ImportList);
+			}
 ;
 
 DefinitionModule:
-	DEFINITION
-	{
-#ifdef DEBUG
-		debug("Definition module");
-#endif DEBUG
-	}
-	MODULE IDENT ';' import* 
-	/* export?
+	DEFINITION	{ state = DEFINITION; }
+	MODULE IDENT
+	';'
+	import(0)* 
+	/*	export?
 
-	   New Modula-2 does not have export lists in definition modules.
+	   	New Modula-2 does not have export lists in definition modules.
 	*/
 	definition* END IDENT '.'
 ;
@@ -96,19 +100,17 @@ definition:
 ;
 
 ProgramModule:
-	MODULE
-	{
-#ifdef DEBUG
-		debug("Program module");
-#endif DEBUG
-	}
-	IDENT priority? ';' import* block IDENT '.'
+	MODULE		{ if (state != IMPLEMENTATION) state = PROGRAM; }
+	IDENT priority? ';' import(0)* block IDENT '.'
 ;
 
 Module:
 	DefinitionModule
 |
-	IMPLEMENTATION? ProgramModule
+	[
+		IMPLEMENTATION	{ state = IMPLEMENTATION; }
+	]?
+	ProgramModule
 ;
 
 CompilationUnit:

lang/m2/comp/scope.C

@@ -0,0 +1,62 @@
+/* S C O P E   M E C H A N I S M */
+
+static char *RcsId = "$Header$";
+
+#include	<assert.h>
+#include	<alloc.h>
+#include	"scope.h"
+
+static int maxscope;		/* maximum assigned scope number */
+
+struct scope *CurrentScope;
+
+/* STATICALLOCDEF "scope" */
+
+/*	Open a scope that is either open (automatic imports) or closed.
+	A closed scope is handled by adding an extra entry to the list
+	with scope number 0. This has two purposes: it makes scope 0
+	visible, and it marks the end of a visibility list.
+	Scope 0 is the pervasive scope, the one that is always visible.
+	A disadvantage of this method is that we cannot open scope 0
+	explicitly.
+*/
+open_scope(scopetype, scopenr)
+{
+	register struct scope *sc = new_scope();
+	register struct scope *sc1;
+
+	sc->sc_scope = scopenr == 0 ? ++maxscope : scopenr;
+	assert(scopetype == OPENSCOPE || scopetype == CLOSEDSCOPE);
+	sc1 = CurrentScope;
+	if (scopetype == CLOSEDSCOPE) {
+		sc1 = new_scope();
+		sc1->sc_scope = 0;			/* Pervasive scope nr */
+		sc1->next = CurrentScope;
+	}
+	sc->next = sc1;
+	CurrentScope = sc;
+}
+
+close_scope()
+{
+	register struct scope *sc = CurrentScope;
+
+	assert(sc != 0);
+	if (sc->next && (sc->next->sc_scope == 0)) {
+		struct scope *sc1 = sc;
+
+		sc = sc->next;
+		free_scope(sc1);
+	}
+	CurrentScope = sc->next;
+	free_scope(sc);
+}
+
+init_scope()
+{
+	register struct scope *sc = new_scope();
+
+	sc->sc_scope = 0;
+	sc->next = 0;
+	CurrentScope = sc;
+}

lang/m2/comp/scope.h

@@ -0,0 +1,19 @@
+/* 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) */
+
+struct scope {
+	struct scope *next;
+	int sc_scope;		/* The scope number. Scope number 0 indicates
+				   both the pervasive scope and the end of a
+				   visibility range
+				*/
+};
+
+extern struct scope
+	*CurrentScope;
+
+#define nextvisible(x)	((x)->sc_scope ? (x)->next : (struct scope *) 0)

lang/m2/comp/statement.g

@@ -1,3 +1,5 @@
+/* S T A T E M E N T S */
+
 {
 static char *RcsId = "$Header$";
 }

lang/m2/comp/tokenname.c

@@ -1,6 +1,10 @@
-#include "tokenname.h"
-#include "Lpars.h"
-#include "idf.h"
+/* T O K E N   D E F I N I T I O N S */
+
+static char *RcsId = "$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
@@ -9,8 +13,6 @@
 	Also, the "token2str.c" file is produced from this file.
 */
 
-static char *RcsId = "$Header$";
-
 struct tokenname tkspec[] =	{	/* the names of the special tokens */
 	{IDENT, "identifier"},
 	{STRING, "string"},
@@ -73,10 +75,18 @@ struct tokenname tkidf[] =	{	/* names of the identifier tokens */
 };
 
 struct tokenname tkinternal[] = {	/* internal keywords	*/
+	{PROGRAM, ""},
 	{0, "0"}
 };
 
 struct tokenname tkstandard[] =	{	/* standard identifiers */
+	{CHAR, "CHAR"},
+	{BOOLEAN, "BOOLEAN"},
+	{LONGINT, "LONGINT"},
+	{CARDINAL, "CARDINAL"},
+	{LONGREAL, "LONGREAL"},
+	{SUBRANGE, ""},
+	{ERRONEOUS, ""},
 	{0, ""}
 };
 

lang/m2/comp/tokenname.h

@@ -1,4 +1,7 @@
+/* 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
 				*/

lang/m2/comp/type.H

@@ -0,0 +1,90 @@
+/* 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 *next;
+	struct type *par_type;	/* Parameter type */
+	int par_var;		/* flag, set if VAR parameter */
+};
+
+/* ALLOCDEF "paramlist" */
+
+struct enume {
+	struct def *en_enums;	/* Definitions of enumeration literals */
+	unsigned int en_ncst;	/* Number of constants */
+	label en_rck;		/* Label of range check descriptor */
+};
+
+struct subrange {
+	arith su_lb, su_ub;	/* Lower bound and upper bound */
+	label su_rck;		/* Label of range check descriptor */
+};
+
+struct array {
+	struct type *ar_index;	/* Type of index */
+	arith ar_lb, ar_ub;	/* Lower bound and upper bound */
+	label ar_descr;		/* Label of array descriptor */
+};
+
+struct record {
+	int rc_scopenr;		/* Scope number of this record */
+				/* Members are in the symbol table */
+};
+
+struct proc {
+	struct paramlist *pr_params;
+};
+
+struct type	{
+	struct type *next;	/* used with ARRAY, PROCEDURE, POINTER, SET,
+				   SUBRANGE
+				*/
+	int tp_fund;		/* fundamental type  or constructor */
+	int tp_align;		/* alignment requirement of this type */
+	arith tp_size;		/* size of this type */
+/*	struct idf *tp_idf;	/* name 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" */
+
+extern struct type
+	*char_type,
+	*int_type,
+	*card_type,
+	*longint_type,
+	*real_type,
+	*longreal_type,
+	*error_type;
+
+extern int
+	wrd_align,
+	int_align,
+	lint_align,
+	real_align,
+	lreal_align,
+	ptr_align,
+	record_align;
+
+extern arith
+	wrd_size,
+	int_size,
+	lint_size,
+	real_size,
+	lreal_size,
+	ptr_size;
+
+extern arith
+	align();
+
+struct type
+	*create_type(),
+	*construct_type(),
+	*standard_type();

lang/m2/comp/type.c

@@ -0,0 +1,134 @@
+/*	T Y P E   D E F I N I T I O N   M E C H A N I S M	 */
+
+static char *RcsId = "$Header$";
+
+#include	<assert.h>
+#include	<alloc.h>
+#include	<em_arith.h>
+#include	<em_label.h>
+#include	"def_sizes.h"
+#include	"Lpars.h"
+#include	"def.h"
+#include	"type.h"
+#include	"idf.h"
+
+/*	To be created dynamically in main() from defaults or from command
+	line parameters.
+*/
+int
+	wrd_align = AL_WORD,
+	int_align = AL_INT,
+	lint_align = AL_LONG,
+	real_align = AL_FLOAT,
+	lreal_align = AL_DOUBLE,
+	ptr_align = AL_POINTER,
+	record_align = AL_STRUCT;
+
+arith
+	wrd_size = SZ_WORD,
+	int_size = SZ_INT,
+	lint_size = SZ_LONG,
+	real_size = SZ_FLOAT,
+	lreal_size = SZ_DOUBLE,
+	ptr_size = SZ_POINTER;
+
+struct type
+	*bool_type,
+	*char_type,
+	*int_type,
+	*card_type,
+	*longint_type,
+	*real_type,
+	*longreal_type,
+	*error_type;
+
+struct paramlist *h_paramlist;
+
+struct type *h_type;
+
+struct type *
+create_type(fund)
+	register int fund;
+{
+	/*	A brand new struct type is created, and its tp_fund set
+		to fund.
+	*/
+	register struct type *ntp = new_type();
+
+	clear((char *)ntp, sizeof(struct type));
+	ntp->tp_fund = fund;
+	ntp->tp_size = (arith)-1;
+
+	return ntp;
+}
+
+struct type *
+construct_type(fund, tp, count)
+	struct type *tp;
+	arith count;
+{
+	/*	fund must be a type constructor.
+		The pointer to the constructed type is returned.
+	*/
+	struct type *dtp = create_type(fund);
+
+	switch (fund)	{
+	case PROCEDURE:
+	case POINTER:
+		dtp->tp_align = ptr_align;
+		dtp->tp_size = ptr_size;
+		dtp->next = tp;
+		break;
+	case SET:
+		dtp->tp_align = wrd_align;
+		dtp->tp_size = align((count + 7) / 8, wrd_align);
+		dtp->next = tp;
+		break;
+	case ARRAY:
+		dtp->tp_align = tp->tp_align;
+		if (tp->tp_size < 0) dtp->tp_size = -1;
+		else dtp->tp_size = count * tp->tp_size;
+		dtp->next = tp;
+		break;
+	case SUBRANGE:
+		dtp->tp_align = tp->tp_align;
+		dtp->tp_size = tp->tp_size;
+		dtp->next = tp;
+		break;
+	default:
+		assert(0);
+	}
+	return dtp;
+}
+
+arith
+align(pos, al)
+	arith pos;
+	int al;
+{
+	return ((pos + al - 1) / al) * al;
+}
+
+struct type *
+standard_type(fund, align, size)
+	int align; arith size;
+{
+	register struct type *tp = create_type(fund);
+
+	tp->tp_align = align;
+	tp->tp_size = size;
+
+	return tp;
+}
+
+init_types()
+{
+	char_type = standard_type(CHAR, 1, (arith) 1);
+	bool_type = standard_type(BOOLEAN, 1, (arith) 1);
+	int_type = standard_type(INTEGER, int_align, int_size);
+	longint_type = standard_type(LONGINT, lint_align, lint_size);
+	card_type = standard_type(CARDINAL, int_align, int_size);
+	real_type = standard_type(REAL, real_align, real_size);
+	longreal_type = standard_type(LONGREAL, lreal_align, lreal_size);
+	error_type = standard_type(ERRONEOUS, 1, (arith) 1);
+}