newer version, safety commit

lang/m2/comp/LLlex.c

@@ -19,12 +19,12 @@ long str2long();
 
 struct token dot, aside;
 
-/*	Skip Modula-2 like comment (* ... *).
-	Note that comment may be nested.
-*/
 static
 SkipComment()
 {
+	/*	Skip Modula-2 comments (* ... *).
+		Note that comments may be nested (par. 3.5).
+	*/
 	register int ch;
 	register int NestLevel = 0;
 
@@ -62,6 +62,8 @@ SkipComment()
 static char *
 GetString(upto)
 {
+	/*	Read a Modula-2 string, delimited by the character "upto".
+	*/
 	register int ch;
 	int str_size;
 	char *str = Malloc(str_size = 32);
@@ -88,12 +90,12 @@ GetString(upto)
 	return str;
 }
 
-/*	LLlex() plays the role of Lexical Analyzer for the parser.
-	The putting aside of tokens is taken into account.
-*/
 int
 LLlex()
 {
+	/*	LLlex() plays the role of Lexical Analyzer for the parser.
+		The putting aside of tokens is taken into account.
+	*/
 	register struct token *tk = ˙
 	char buf[(IDFSIZE > NUMSIZE ? IDFSIZE : NUMSIZE) + 1];
 	register int ch, nch;
@@ -378,4 +380,3 @@ Sdec:
 	}
 	/*NOTREACHED*/
 }
-

lang/m2/comp/Makefile

@@ -4,17 +4,20 @@
 HDIR =	../../em/h
 PKGDIR =	../../em/pkg
 LIBDIR =	../../em/lib
+
 INCLUDES = -I$(HDIR) -I$(PKGDIR) -I/user1/erikb/em/h
+
 LSRC =	tokenfile.g program.g declar.g expression.g statement.g
 CC =	cc
 GEN =	LLgen
 GENOPTIONS =
-CFLAGS =	-DDEBUG -p $(INCLUDES)
+PROFILE =
-LFLAGS =	-p
+CFLAGS = -DDEBUG $(PROFILE) $(INCLUDES)
+LFLAGS = $(PROFILE)
 LOBJ =	tokenfile.o program.o declar.o expression.o statement.o
 COBJ =	LLlex.o LLmessage.o char.o error.o main.o \
 	symbol2str.o tokenname.o idf.o input.o type.o def.o \
-	scope.o misc.o print.o enter.o defmodule.o
+	scope.o misc.o enter.o defmodule.o
 OBJ =	$(COBJ) $(LOBJ) Lpars.o
 GENFILES=	tokenfile.c \
 	program.c declar.c expression.c statement.c \
@@ -29,7 +32,7 @@ LLfiles:	$(LSRC)
 	@touch LLfiles
 
 main:	$(OBJ) Makefile
-	$(CC) $(LFLAGS) $(OBJ) $(LIBDIR)/libcomp.a $(LIBDIR)/malloc.o /user1/erikb/em/lib/libstr.a /user1/erikb/em/lib/libsystem.a -o main
+	$(CC) $(LFLAGS) $(OBJ) $(LIBDIR)/libcomp.a $(LIBDIR)/malloc.o /user1/erikb/em/lib/libprint.a /user1/erikb/em/lib/libstr.a /user1/erikb/em/lib/libsystem.a -o main
 	size main
 
 clean:
@@ -68,7 +71,7 @@ depend:
 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 input.h
+error.o: LLlex.h f_info.h input.h main.h
 main.o: LLlex.h Lpars.h debug.h def.h f_info.h idf.h input.h main.h scope.h standards.h type.h
 symbol2str.o: Lpars.h
 tokenname.o: Lpars.h idf.h tokenname.h

lang/m2/comp/def.c

@@ -52,7 +52,7 @@ define(id, scope, kind)
 			}
 			break;	
 		case D_HIDDEN:
-			if (kind == D_TYPE && state == IMPLEMENTATION) {
+			if (kind == D_TYPE && !DefinitionModule) {
 				df->df_kind = D_HTYPE;
 				return df;
 			}
@@ -145,7 +145,7 @@ Import(ids, id, local)
 	/*	"ids" is a list of imported identifiers.
 		If "id" is a null-pointer, the identifiers are imported from the
 		enclosing scope. Otherwise they are imported from the module
-		indicated by "id", ehich must be visible in the enclosing scope.
+		indicated by "id", which must be visible in the enclosing scope.
 		An exception must be made for imports of the Compilation Unit.
 		This case is indicated by  the value 0 of the flag "local".
 		In this case, if "id" is a null pointer, the "ids" identifiers
@@ -224,3 +224,52 @@ exprt_literals(df, toscope)
 		df = df->enm_next;
 	}
 }
+
+RemImports(pdf)
+	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, *df1 = 0;
+
+	while (df) {
+		if (df->df_kind == D_IMPORT) {
+			RemFromId(df);
+			if (df1) {
+				df1->df_nextinscope = df->df_nextinscope;
+				free_def(df);
+				df = df1->df_nextinscope;
+			}
+			else {
+				*pdf = df->df_nextinscope;
+				free_def(df);
+				df = *pdf;
+			}
+		}
+		else {
+			df1 = df;
+			df = df->df_nextinscope;
+		}
+	}
+}
+
+RemFromId(df)
+	struct def *df;
+{
+	/*	Remove definition "df" from the definition list
+	*/
+	register struct idf *id = df->df_idf;
+	register struct def *df1;
+
+	if (id->id_def == df) id->id_def = df->next;
+	else {
+		df1 = id->id_def;
+		while (df1->next != df) {
+			assert(df1->next != 0);
+			df1 = df1->next;
+		}
+		df1->next = df->next;
+	}
+}

lang/m2/comp/enter.c

@@ -76,6 +76,6 @@ lookfor(id, scope, give_error)
 		if (df) return df;
 		sc = nextvisible(sc);
 	}
-	if (give_error) error("identifier \"%s\" not declared", id->id_text);
+	if (give_error) id_not_declared(id);
 	return define(id, scope, D_ERROR);
 }

lang/m2/comp/error.c

@@ -12,6 +12,7 @@ static char *RcsId = "$Header$";
 #include	"input.h"
 #include	"f_info.h"
 #include	"LLlex.h"
+#include	"main.h"
 
 #define MAXERR_LINE	5	/* Number of error messages on one line ... */
 #define	ERROUT		STDERR
@@ -32,7 +33,6 @@ static char *RcsId = "$Header$";
 int err_occurred;
 
 extern char *symbol2str();
-extern char options[];
 
 /*	There are three general error-message functions:
 		lexerror()	lexical and pre-processor error messages
@@ -198,10 +198,10 @@ _error(class, expr, fmt, argv)
 	}
 #endif DEBUG
 	
-	if (FileName) fprintf(ERROUT, "\"%s\", line %u: ", FileName, ln);
+	if (FileName) fprint(ERROUT, "\"%s\", line %u: ", FileName, ln);
 
-	if (remark) fprintf(ERROUT, "%s ", remark);
+	if (remark) fprint(ERROUT, "%s ", remark);
 
 	doprnt(ERROUT, fmt, argv);		/* contents of error */
-	fprintf(ERROUT, "\n");
+	fprint(ERROUT, "\n");
 }

lang/m2/comp/expression.g

@@ -43,10 +43,9 @@ qualident(int types; struct def **pdf; char *str;)
 				module = (df->df_kind == D_MODULE);
 				df = lookup(dot.TOK_IDF, scope);
 				if (!df) {
-					error("identifier \"%s\" not declared",
-					      dot.TOK_IDF->id_text);
 					types = 0;
 					df = ill_df;
+					id_not_declared(dot.TOK_IDF);
 				}
 				else
 				if (module &&

lang/m2/comp/main.c

@@ -17,12 +17,13 @@ static char *RcsId = "$Header$";
 #include	"scope.h"
 #include	"standards.h"
 
-char options[128];
+char	options[128];
-char *ProgName;
+int	DefinitionModule; 
-int state;
+int	SYSTEMModule = 0;
+char	*ProgName;
 extern int err_occurred;
-char *DEFPATH[128];
+char	*DEFPATH[128];
-char *getenv();
+char	*getenv();
 
 main(argc, argv)
 	char *argv[];
@@ -40,11 +41,11 @@ main(argc, argv)
 	}
 	Nargv[Nargc] = 0;	/* terminate the arg vector	*/
 	if (Nargc != 2) {
-		fprintf(STDERR, "%s: Use one file argument\n", ProgName);
+		fprint(STDERR, "%s: Use one file argument\n", ProgName);
 		return 1;
 	}
 #ifdef DEBUG
-	printf("Mod2 compiler -- Debug version\n");
+	print("Mod2 compiler -- Debug version\n");
 #endif DEBUG
 	DO_DEBUG(debug(1,"Debugging level: %d", options['D']));
 	return !Compile(Nargv[1]);
@@ -57,7 +58,7 @@ Compile(src)
 
 	DO_DEBUG(debug(1,"Filename : %s", src));
 	if (! InsertFile(src, (char **) 0, &src)) {
-		fprintf(STDERR,"%s: cannot open %s\n", ProgName, src);
+		fprint(STDERR,"%s: cannot open %s\n", ProgName, src);
 		return 0;
 	}
 	LineNumber = 1;
@@ -92,23 +93,23 @@ LexScan()
 	register int symb;
 
 	while ((symb = LLlex()) != EOI) {
-		printf(">>> %s ", symbol2str(symb));
+		print(">>> %s ", symbol2str(symb));
 		switch(symb) {
 
 		case IDENT:
-			printf("%s\n", dot.TOK_IDF->id_text);
+			print("%s\n", dot.TOK_IDF->id_text);
 			break;
 		
 		case INTEGER:
-			printf("%ld\n", dot.TOK_INT);
+			print("%ld\n", dot.TOK_INT);
 			break;
 		
 		case REAL:
-			printf("%s\n", dot.TOK_REL);
+			print("%s\n", dot.TOK_REL);
 			break;
 		
 		case STRING:
-			printf("\"%s\"\n", dot.TOK_STR);
+			print("\"%s\"\n", dot.TOK_STR);
 			break;
 
 		default:
@@ -159,7 +160,7 @@ add_standards()
 	(void) Enter("LONGREAL", D_TYPE, longreal_type, 0);
 	(void) Enter("BOOLEAN", D_TYPE, bool_type, 0);
 	(void) Enter("CARDINAL", D_TYPE, card_type, 0);
-	(void) Enter("NIL", D_CONST, nil_type, 0);
+	(void) Enter("NIL", D_CONST, address_type, 0);
 	(void) Enter("PROC",
 		     D_TYPE,
 		     construct_type(PROCEDURE, NULLTYPE),
@@ -196,13 +197,29 @@ do_SYSTEM()
 {
 	/*	Simulate the reading of the SYSTEM definition module
 	*/
-	struct def *df;
+	char *SYSTEM = "\
-	struct idf *sys_id;
+DEFINITION MODULE SYSTEM;\n\
+PROCEDURE NEWPROCESS(P:PROC; A:ADDRESS; n:CARDINAL; VAR p1:ADDRESS);\n\
+PROCEDURE TRANSFER(VAR p1,p2:ADDRESS);\n\
+END SYSTEM.\n";
 
-	sys_id = str2idf("SYSTEM", 0);
-	df = define(sys_id, GlobalScope, D_MODULE);
 	open_scope(CLOSEDSCOPE, 0);
-	df->mod_scope = CurrentScope->sc_scope;
+	(void) Enter("WORD", D_TYPE, word_type, 0);
-	/* ???? */
+	(void) Enter("ADDRESS", D_TYPE, address_type, 0);
+	(void) Enter("ADR", D_STDFUNC, NULLTYPE, S_ADR);
+	(void) Enter("TSIZE", D_STDFUNC, NULLTYPE, S_TSIZE);
+	if (!InsertText(SYSTEM, strlen(SYSTEM))) {
+		fatal("Could not insert text");
+	}
+	SYSTEMModule = 1;
+	DefModule();
 	close_scope();
+	SYSTEMModule = 0;
+}
+
+AtEoIT()
+{
+	/*	Make the end of the text noticable
+	*/
+	return 1;
 }

lang/m2/comp/main.h

@@ -2,7 +2,13 @@
 
 /* $Header$ */
 
-extern int
+extern char options[];	/* Indicating which options were given */
-	state;		/* Indicates what we are compiling: A DEFINITION,
+
-			   an IMPLEMENTATION, or a PROGRAM module
+extern int DefinitionModule;
+			/* Flag indicating that we are reading a definition
+			   module
+			*/
+
+extern int SYSTEMModule;/* Flag indicating that we are handling the SYSTEM
+			   module
 			*/

lang/m2/comp/misc.c

@@ -48,9 +48,20 @@ gen_anon_idf()
 	*/
 	static int name_cnt;
 	char buff[100];
-	char *sprintf();
+	char *sprint();
 
-	sprintf(buff, "#%d in %s, line %u",
+	sprint(buff, "#%d in %s, line %u",
 			++name_cnt, FileName, LineNumber);
 	return str2idf(buff, 1);
 }
+
+id_not_declared(id)
+	struct idf *id;
+{
+	/*	The identifier "id" is not declared. If it is not generated,
+		give an error message
+	*/
+	if (!is_anon_idf(id)) {
+		error("identifier \"%s\" not declared", id->id_text);
+	}
+}

lang/m2/comp/program.g

@@ -14,6 +14,9 @@ static  char *RcsId = "$Header$";
 #include	"def.h"
 #include	"type.h"
 #include	"debug.h"
+
+static struct idf *impl_name = 0;
+static struct def *impl_df;
 }
 /*
 	The grammar as given by Wirth is already almost LL(1); the
@@ -101,30 +104,41 @@ DefinitionModule
 	register struct def *df;
 	struct idf *id;
 } :
-	DEFINITION	{ state = DEFINITION; }
+	DEFINITION
 	MODULE IDENT	{ id = dot.TOK_IDF;
 			  df = define(id, GlobalScope, D_MODULE);
-			  open_scope(CLOSEDSCOPE, 0);
+			  if (!SYSTEMModule) open_scope(CLOSEDSCOPE, 0);
 			  df->mod_scope = CurrentScope->sc_scope;
+			  DefinitionModule = 1;
 			  DO_DEBUG(debug(1, "Definition module \"%s\"", id->id_text));
 			}
 	';'
 	import(0)* 
 	export(1)?
-
 	/*	New Modula-2 does not have export lists in definition modules.
+		For the time being, we ignore export lists here, and a
+		warning is issued.
 	*/
-	definition* END IDENT '.'
+	definition* END IDENT
 			{
+			  if (id == impl_name) {
+				/* Just read the definition module of the
+				   implementation module being compiled
+				*/
+				RemImports(&(CurrentScope->sc_def));
+				impl_df = CurrentScope->sc_def;
+			  }
 			  df = CurrentScope->sc_def;
 			  while (df) {
 				/* Make all definitions "QUALIFIED EXPORT" */
 				df->df_flags |= D_QEXPORTED;
 				df = df->df_nextinscope;
 			  }
-			  close_scope();
+			  if (!SYSTEMModule) close_scope();
+			  DefinitionModule = 0;
 			  match_id(id, dot.TOK_IDF);
 			}
+	'.'
 ;
 
 definition
@@ -153,20 +167,23 @@ definition
 	ProcedureHeading(&df, D_PROCHEAD) ';'
 ;
 
-ProgramModule
+ProgramModule(int state;)
 {
 	struct idf *id;
 	struct def *df, *GetDefinitionModule();
 	int scope = 0;
 } :
-	MODULE		{ if (state != IMPLEMENTATION) state = PROGRAM; }
+	MODULE
 	IDENT		{ 
 			  id = dot.TOK_IDF;
 			  if (state == IMPLEMENTATION) {
+				   impl_name = id;
 				   df = GetDefinitionModule(id);
 				   scope = df->mod_scope;
 			  }
+			  DefinitionModule = 0;
 			  open_scope(CLOSEDSCOPE, scope);
+			  CurrentScope->sc_def = impl_df;
 			}
 	priority?
 	';' import(0)*
@@ -177,13 +194,16 @@ ProgramModule
 	'.'
 ;
 
-Module:
+Module
+{
+	int state = PROGRAM;
+} :
 	DefinitionModule
 |
 	[
 		IMPLEMENTATION	{ state = IMPLEMENTATION; }
 	]?
-	ProgramModule
+	ProgramModule(state)
 ;
 
 CompilationUnit:

lang/m2/comp/standards.h

@@ -21,4 +21,8 @@
 #define S_VAL	17
 
 /* Standard procedures and functions defined in the SYSTEM module ... */
-/* PM ??? */
+
+#define S_ADR	20
+#define S_TSIZE	21
+#define S_NEWPROCESS	22
+#define S_TRANSFER	23

lang/m2/comp/tokenname.c

@@ -88,6 +88,8 @@ struct tokenname tkstandard[] =	{	/* standard identifiers */
 	{SUBRANGE, ""},
 	{ENUMERATION, ""},
 	{ERRONEOUS, ""},
+	{WORD, ""},
+	{ADDRESS, ""},
 	{0, ""}
 };
 

lang/m2/comp/type.H

@@ -75,7 +75,8 @@ extern struct type
 	*longint_type,
 	*real_type,
 	*longreal_type,
-	*nil_type,
+	*word_type,
+	*address_type,
 	*error_type;
 
 extern int

lang/m2/comp/type.c

@@ -41,7 +41,8 @@ struct type
 	*longint_type,
 	*real_type,
 	*longreal_type,
-	*nil_type,
+	*word_type,
+	*address_type,
 	*error_type;
 
 struct paramlist *h_paramlist;
@@ -128,8 +129,10 @@ init_types()
 	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);
-	nil_type = standard_type(POINTER, ptr_align, ptr_size);
+	word_type = standard_type(WORD, wrd_align, wrd_size);
+	address_type = construct_type(POINTER, word_type);
 	error_type = standard_type(ERRONEOUS, 1, (arith) 1);
+
 }
 
 int