newer version, safety commit

lang/m2/comp/Makefile

@@ -14,7 +14,7 @@ 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 type.o def.o \
-	scope.o misc.o print.o
+	scope.o misc.o print.o enter.o
 OBJ =	$(COBJ) $(LOBJ) Lpars.o
 GENFILES=	tokenfile.c \
 	program.c declar.c expression.c statement.c \
@@ -69,17 +69,18 @@ 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
-main.o: LLlex.h Lpars.h debug.h f_info.h idf.h input.h main.h
+main.o: LLlex.h Lpars.h debug.h def.h f_info.h idf.h input.h main.h standards.h type.h
 symbol2str.o: Lpars.h
 tokenname.o: Lpars.h idf.h tokenname.h
 idf.o: idf.h
 input.o: f_info.h input.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
+scope.o: debug.h scope.h
 misc.o: LLlex.h f_info.h idf.h misc.h
+enter.o: def.h idf.h scope.h type.h
 tokenfile.o: Lpars.h
-program.o: LLlex.h Lpars.h idf.h main.h misc.h
+program.o: LLlex.h Lpars.h idf.h main.h misc.h scope.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

lang/m2/comp/def.H

@@ -49,6 +49,8 @@ struct def	{		/* list of definitions for a name */
 #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_STDPROC	0x0B	/* A standard procedure */
+#define D_STDFUNC	0x0C	/* A standard function */
 #define D_ISEXPORTED	0xFF	/* Not yet defined */
 	char df_flags;
 #define D_ADDRESS	0x01	/* Set if address was taken */
@@ -65,6 +67,7 @@ struct def	{		/* list of definitions for a name */
 		struct enumval df_enum;
 		struct field df_field;
 		struct import df_import;
+		int df_stdname;	/* Define for standard name */
 	} df_value;
 };
 

lang/m2/comp/def.c

@@ -16,14 +16,18 @@ struct def *h_def;		/* Pointer to free list of def structures */
 struct def *
 define(id, scope, kind)
 	register struct idf *id;
-	struct scope *scope;
+	register 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);
+	register struct def *df = lookup(id, scope->sc_scope);
 
-	if (df) {
+	if (	/* Already in this scope */
+		df
+	   ||	/* A closed scope, and id defined in the pervasive scope */
+		(scopeclosed(scope) && (df = lookup(id, 0)))
+	   ) {
 		switch(df->df_kind) {
 		case D_PROCHEAD:
 			if (kind == D_PROCEDURE) {
@@ -57,7 +61,6 @@ define(id, scope, kind)
 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.
@@ -69,7 +72,7 @@ lookup(id, scope)
 	df1 = 0;
 	df = id->id_def;
 	while (df) {
-		if (df->df_scope == scope->sc_scope) {
+		if (df->df_scope == scope) {
 			if (df1) {
 				df1->next = df->next;
 				df->next = id->id_def;

lang/m2/comp/enter.c

@@ -0,0 +1,29 @@
+/* H I G H   L E V E L   S Y M B O L   E N T R Y   A N D   L O O K U P */
+
+static char *RcsId = "$Header$";
+
+#include	<em_arith.h>
+#include	<em_label.h>
+#include	"idf.h"
+#include	"def.h"
+#include	"type.h"
+#include	"scope.h"
+
+extern struct idf *str2idf();
+extern struct def *define();
+
+Enter(name, kind, type, pnam)
+	char *name;
+	struct type *type;
+{
+	struct idf *id;
+	struct def *df;
+
+	id = str2idf(name, 0);
+	if (!id) fatal("Out of core");
+	df = define(id, CurrentScope, kind);
+	df->df_type = type;
+	if (kind == D_STDPROC || kind == D_STDFUNC) {
+		df->df_value.df_stdname = pnam;
+	}
+}

lang/m2/comp/error.c

@@ -170,6 +170,9 @@ _error(class, expr, fmt, argv)
 	case LEXERROR:
 	case CRASH:
 	case FATAL:
+#ifdef DEBUG
+	case VDEBUG:
+#endif DEBUG
 		ln = LineNumber;
 		break;
 	}
@@ -180,8 +183,7 @@ _error(class, expr, fmt, argv)
 	if (ln == last_ln)	{
 		/* we've seen this place before */
 		e_seen++;
-		if (e_seen == MAXERR_LINE)
+		if (e_seen == MAXERR_LINE) fmt = "etc ...";
-			fmt = "etc ...";
 		else
 		if (e_seen > MAXERR_LINE)
 			/* and too often, I'd say ! */
@@ -192,14 +194,14 @@ _error(class, expr, fmt, argv)
 		last_ln = ln;
 		e_seen = 0;
 	}
-	
-	if (FileName)
-		fprintf(ERROUT, "\"%s\", line %u: ", FileName, ln);
-	if (remark)
-		fprintf(ERROUT, "%s ", remark);
 #ifdef DEBUG
 	}
-#endif
+#endif DEBUG
+	
+	if (FileName) fprintf(ERROUT, "\"%s\", line %u: ", FileName, ln);
+
+	if (remark) fprintf(ERROUT, "%s ", remark);
+
 	doprnt(ERROUT, fmt, argv);		/* contents of error */
 	fprintf(ERROUT, "\n");
 }

lang/m2/comp/main.c

@@ -4,6 +4,7 @@ static char *RcsId = "$Header$";
 
 #include	<system.h>
 #include	<em_arith.h>
+#include	<em_label.h>
 #include	"input.h"
 #include	"f_info.h"
 #include	"idf.h"
@@ -11,6 +12,9 @@ static char *RcsId = "$Header$";
 #include	"Lpars.h"
 #include	"main.h"
 #include	"debug.h"
+#include	"type.h"
+#include	"def.h"
+#include	"standards.h"
 
 char options[128];
 char *ProgName;
@@ -48,9 +52,7 @@ Compile(src)
 {
 	extern struct tokenname tkidf[];
 
-#ifdef DEBUG
+	DO_DEBUG(debug(1,"Filename : %s", src));
-	printf("%s\n", src);
-#endif DEBUG
 	if (! InsertFile(src, (char **) 0)) {
 		fprintf(STDERR,"%s: cannot open %s\n", ProgName, src);
 		return 0;
@@ -61,6 +63,7 @@ Compile(src)
 	reserve(tkidf);
 	init_scope();
 	init_types();
+	add_standards();
 #ifdef DEBUG
 	if (options['L'])
 		LexScan();
@@ -117,3 +120,56 @@ Option(str)
 {
 	options[str[1]]++;	/* switch option on	*/
 }
+
+#define NULLTYPE	((struct type *) 0)
+
+add_standards()
+{
+	register struct def *df;
+	register struct type *tp;
+	struct def *Enter();
+
+	(void) Enter("ABS", D_STDFUNC, NULLTYPE, S_ABS);
+	(void) Enter("CAP", D_STDFUNC, NULLTYPE, S_CAP);
+	(void) Enter("CHR", D_STDFUNC, NULLTYPE, S_CHR);
+	(void) Enter("FLOAT", D_STDFUNC, NULLTYPE, S_FLOAT);
+	(void) Enter("HIGH", D_STDFUNC, NULLTYPE, S_HIGH);
+	(void) Enter("HALT", D_STDPROC, NULLTYPE, S_HALT);
+	(void) Enter("EXCL", D_STDPROC, NULLTYPE, S_EXCL);
+	(void) Enter("DEC", D_STDPROC, NULLTYPE, S_DEC);
+	(void) Enter("INC", D_STDPROC, NULLTYPE, S_INC);
+	(void) Enter("VAL", D_STDFUNC, NULLTYPE, S_VAL);
+	(void) Enter("TRUNC", D_STDFUNC, NULLTYPE, S_TRUNC);
+	(void) Enter("SIZE", D_STDFUNC, NULLTYPE, S_SIZE);
+	(void) Enter("ORD", D_STDFUNC, NULLTYPE, S_ORD);
+	(void) Enter("ODD", D_STDFUNC, NULLTYPE, S_ODD);
+	(void) Enter("MAX", D_STDFUNC, NULLTYPE, S_MAX);
+	(void) Enter("MIN", D_STDFUNC, NULLTYPE, S_MIN);
+	(void) Enter("INCL", D_STDPROC, NULLTYPE, S_INCL);
+
+	(void) Enter("CHAR", D_TYPE, char_type, 0);
+	(void) Enter("INTEGER", D_TYPE, int_type, 0);
+	(void) Enter("LONGINT", D_TYPE, longint_type, 0);
+	(void) Enter("REAL", D_TYPE, real_type, 0);
+	(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("PROC",
+		     D_TYPE,
+		     construct_type(PROCEDURE, NULLTYPE, (arith) 0),
+		     0);
+	tp = construct_type(SUBRANGE, int_type, (arith) 0);
+	tp->tp_value.tp_subrange.su_lb = 0;
+	tp->tp_value.tp_subrange.su_ub = wrd_size * 8 - 1;
+	(void) Enter("BITSET",
+		     D_TYPE,
+		     construct_type(SET, tp, wrd_size),
+		     0);
+	df = Enter("FALSE", D_ENUM, bool_type, 0);
+	df->df_value.df_enum.en_val = 0;
+	df->df_value.df_enum.en_next = Enter("TRUE", D_ENUM, bool_type, 0);
+	df = df->df_value.df_enum.en_next;
+	df->df_value.df_enum.en_val = 1;
+	df->df_value.df_enum.en_next = 0;
+}

lang/m2/comp/program.g

@@ -9,6 +9,7 @@ static  char *RcsId = "$Header$";
 #include	"misc.h"
 #include	"main.h"
 #include	"LLlex.h"
+#include	"scope.h"
 }
 /*
 	The grammar as given by Wirth is already almost LL(1); the
@@ -68,7 +69,7 @@ import(int local;)
 
 DefinitionModule:
 	DEFINITION	{ state = DEFINITION; }
-	MODULE IDENT
+	MODULE IDENT	{ open_scope(CLOSEDSCOPE, 0); }
 	';'
 	import(0)* 
 	/*	export?
@@ -76,6 +77,7 @@ DefinitionModule:
 	   	New Modula-2 does not have export lists in definition modules.
 	*/
 	definition* END IDENT '.'
+			{ close_scope(); }
 ;
 
 definition:
@@ -101,7 +103,15 @@ definition:
 
 ProgramModule:
 	MODULE		{ if (state != IMPLEMENTATION) state = PROGRAM; }
-	IDENT priority? ';' import(0)* block IDENT '.'
+	IDENT		{ if (state == IMPLEMENTATION) {
+				/* Re-open scope ??? */
+				open_scope(CLOSEDSCOPE, 0);
+			  }
+			  else	open_scope(CLOSEDSCOPE, 0);
+			}
+	priority? ';' import(0)* block IDENT
+			{ close_scope(); }
+	'.'
 ;
 
 Module:

lang/m2/comp/scope.C

@@ -5,6 +5,7 @@ static char *RcsId = "$Header$";
 #include	<assert.h>
 #include	<alloc.h>
 #include	"scope.h"
+#include	"debug.h"
 
 static int maxscope;		/* maximum assigned scope number */
 
@@ -27,6 +28,7 @@ open_scope(scopetype, scopenr)
 
 	sc->sc_scope = scopenr == 0 ? ++maxscope : scopenr;
 	assert(scopetype == OPENSCOPE || scopetype == CLOSEDSCOPE);
+	DO_DEBUG(debug(1, "Opening a %s scope", scopetype == OPENSCOPE ? "open" : "closed"));
 	sc1 = CurrentScope;
 	if (scopetype == CLOSEDSCOPE) {
 		sc1 = new_scope();
@@ -42,6 +44,7 @@ close_scope()
 	register struct scope *sc = CurrentScope;
 
 	assert(sc != 0);
+	DO_DEBUG(debug(1, "Closing a scope"));
 	if (sc->next && (sc->next->sc_scope == 0)) {
 		struct scope *sc1 = sc;
 

lang/m2/comp/scope.h

@@ -17,3 +17,4 @@ extern struct scope
 	*CurrentScope;
 
 #define nextvisible(x)	((x)->sc_scope ? (x)->next : (struct scope *) 0)
+#define scopeclosed(x)	((x)->next->sc_scope == 0)

lang/m2/comp/standards.h

@@ -0,0 +1,24 @@
+/* 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
+
+/* Standard procedures and functions defined in the SYSTEM module ... */
+/* PM ??? */

lang/m2/comp/tokenname.c

@@ -80,11 +80,11 @@ struct tokenname tkinternal[] = {	/* internal keywords	*/
 };
 
 struct tokenname tkstandard[] =	{	/* standard identifiers */
-	{CHAR, "CHAR"},
+	{CHAR, ""},
-	{BOOLEAN, "BOOLEAN"},
+	{BOOLEAN, ""},
-	{LONGINT, "LONGINT"},
+	{LONGINT, ""},
-	{CARDINAL, "CARDINAL"},
+	{CARDINAL, ""},
-	{LONGREAL, "LONGREAL"},
+	{LONGREAL, ""},
 	{SUBRANGE, ""},
 	{ERRONEOUS, ""},
 	{0, ""}

lang/m2/comp/type.H

@@ -56,12 +56,14 @@ struct type	{
 /* ALLOCDEF "type" */
 
 extern struct type
+	*bool_type,
 	*char_type,
 	*int_type,
 	*card_type,
 	*longint_type,
 	*real_type,
 	*longreal_type,
+	*nil_type,
 	*error_type;
 
 extern int

lang/m2/comp/type.c

@@ -40,6 +40,7 @@ struct type
 	*longint_type,
 	*real_type,
 	*longreal_type,
+	*nil_type,
 	*error_type;
 
 struct paramlist *h_paramlist;
@@ -130,5 +131,6 @@ 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);
 	error_type = standard_type(ERRONEOUS, 1, (arith) 1);
 }