A newer version

lang/m2/comp/LLlex.c

@@ -18,6 +18,7 @@ static char *RcsId = "$Header$";
 long str2long();
 
 struct token dot, aside;
+struct string string;
 
 static
 SkipComment()
@@ -59,16 +60,16 @@ SkipComment()
 	}
 }
 
-static char *
+static
 GetString(upto)
 {
 	/*	Read a Modula-2 string, delimited by the character "upto".
 	*/
 	register int ch;
-	int str_size;
+	register struct string *str = &string;
-	char *str = Malloc(str_size = 32);
+	register char *p;
-	register int pos = 0;
 	
+	str->s_str = p = Malloc(str->s_length = 32);
 	LoadChar(ch);
 	while (ch != upto)	{
 		if (class(ch) == STNL)	{
@@ -80,14 +81,15 @@ GetString(upto)
 			lexerror("end-of-file in string");
 			break;
 		}
-		str[pos++] = ch;
+		*p++ = ch;
-		if (pos == str_size)	{
+		if (p - str->s_str == str->s_length)	{
-			str = Srealloc(str, str_size += 8);
+			str->s_str = Srealloc(str->s_str, str->s_length += 8);
+			p = str->s_str + (str->s_length - 8);
 		}
 		LoadChar(ch);
 	}
-	str[pos] = '\0';
+	*p = '\0';
-	return str;
+	str->s_length = p - str->s_str;
 }
 
 int
@@ -106,13 +108,14 @@ LLlex()
 		return tk->tk_symb;
 	}
 	tk->tk_lineno = LineNumber;
+	tk->tk_filename = FileName;
 
 again:
 	LoadChar(ch);
 	if ((ch & 0200) && ch != EOI) {
 		fatal("non-ascii '\\%03o' read", ch & 0377);
 	}
-	
+
 	switch (class(ch))	{
 
 	case STSKIP:
@@ -205,7 +208,8 @@ again:
 	}
 
 	case STSTR:
-		tk->TOK_STR = GetString(ch);
+		GetString(ch);
+		tk->tk_data.tk_str = string;
 		return tk->tk_symb = STRING;
 
 	case STNUM:

lang/m2/comp/LLlex.h

@@ -2,24 +2,27 @@
 
 /* $Header$ */
 
+struct string {
+	int s_length;		/* length of a string */
+	char *s_str;		/* the string itself */
+};
+
 struct token	{
 	int tk_symb;		/* token itself	*/
+	char *tk_filename;	/* filename in which it occurred */
 	int tk_lineno;		/* linenumber on which it occurred */
 	union {
 		struct idf *tk_idf;	/* IDENT	*/
-		char *tk_str;		/* STRING	*/
+		struct string tk_str;	/* STRING	*/
-		struct {		/* INTEGER	*/
+		arith tk_int;		/* INTEGER	*/
-			struct type *tk_type;	/* type	*/
-			arith tk_value;	/* value	*/
-		} tk_int;
 		char *tk_real;		/* REAL		*/
 	} tk_data;
 };
 
 #define TOK_IDF	tk_data.tk_idf
-#define TOK_STR	tk_data.tk_str
+#define TOK_STR	tk_data.tk_str.s_str
-#define TOK_ITP	tk_data.tk_int.tk_type
+#define TOK_SLE tk_data.tk_str.s_length
-#define TOK_INT	tk_data.tk_int.tk_value
+#define TOK_INT	tk_data.tk_int
 #define TOK_REL	tk_data.tk_real
 
 extern struct token dot, aside;

lang/m2/comp/LLmessage.c

@@ -37,10 +37,10 @@ insert_token(tk)
 		dot.TOK_IDF = gen_anon_idf();
 		break;
 	case STRING:
+		dot.TOK_SLE = 1;
 		dot.TOK_STR = Salloc("", 1);
 		break;
 	case INTEGER:
-/*		dot.TOK_ITP = INT; */
 		dot.TOK_INT = 1;
 		break;
 	case REAL:

lang/m2/comp/Makefile

@@ -17,7 +17,7 @@ LFLAGS = $(PROFILE)
 LOBJ =	tokenfile.o program.o declar.o expression.o statement.o
 COBJ =	LLlex.o LLmessage.o char.o error.o main.o \
 	symbol2str.o tokenname.o idf.o input.o type.o def.o \
-	scope.o misc.o enter.o defmodule.o
+	scope.o misc.o enter.o defmodule.o typequiv.o
 OBJ =	$(COBJ) $(LOBJ) Lpars.o
 GENFILES=	tokenfile.c \
 	program.c declar.c expression.c statement.c \
@@ -83,6 +83,7 @@ scope.o: LLlex.h debug.h def.h idf.h scope.h type.h
 misc.o: LLlex.h f_info.h idf.h misc.h
 enter.o: def.h idf.h misc.h scope.h type.h
 defmodule.o: LLlex.h def.h f_info.h idf.h input.h scope.h
+typequiv.o: Lpars.h def.h type.h
 tokenfile.o: Lpars.h
 program.o: LLlex.h Lpars.h debug.h def.h idf.h main.h misc.h scope.h type.h
 declar.o: LLlex.h Lpars.h def.h idf.h misc.h scope.h type.h

lang/m2/comp/declar.g

@@ -21,6 +21,7 @@ ProcedureDeclaration
 	ProcedureHeading(&df, D_PROCEDURE)
 	';' block IDENT
 			{ match_id(dot.TOK_IDF, df->df_idf);
+			  df->prc_scope = CurrentScope->sc_scope;
 			  close_scope();
 			}
 ;
@@ -28,19 +29,37 @@ ProcedureDeclaration
 ProcedureHeading(struct def **pdf; int type;)
 {
 	struct type *tp;
+	struct type *tp1 = 0;
 	struct paramlist *params = 0;
+	register struct def *df;
 } :
 	PROCEDURE IDENT
 			{ assert(type & (D_PROCEDURE | D_PROCHEAD));
-			  *pdf = define(dot.TOK_IDF, CurrentScope, type);
+			  if (type == D_PROCHEAD) {
-			  if (type == D_PROCEDURE) {
+				df = define(dot.TOK_IDF, CurrentScope, type);
+			  }
+			  else {
+				df = lookup(dot.TOK_IDF,
+						CurrentScope->sc_scope);
+				if (df && df->df_kind == D_PROCHEAD) {
+					df->df_kind = type;
+					tp1 = df->df_type;
+				}
+				else {
+					df = define(dot.TOK_IDF,
+						CurrentScope, type);
+				}
 				open_scope(OPENSCOPE, 0);
 			  }
 			}
 	FormalParameters(type == D_PROCEDURE, &params, &tp)?
 			{
-			  (*pdf)->df_type = tp = construct_type(PROCEDURE, tp);
+			  df->df_type = tp = construct_type(PROCEDURE, tp);
 			  tp->prc_params = params;
+			  if (tp1 && !TstTypeEquiv(tp, tp1)) {
+error("inconsistent procedure declaration for \"%s\"", df->df_idf->id_text); 
+			  }
+			  *pdf = df;
 			}
 ;
 
@@ -283,6 +302,9 @@ FieldList(struct scope *scope;)
 } :
 [
 	IdentList(&FldList) ':' type(&tp)
+			{ EnterIdList(FldList, D_FIELD, 0, tp, scope);
+			  FreeIdList(FldList);
+			}
 |
 	CASE
 	[
@@ -370,7 +392,7 @@ ProcedureType(struct type **ptp;)
 	struct type *tp = 0;
 } :
 	PROCEDURE FormalTypeList(&pr, &tp)?
-			{ *ptp = construct_type(PROCEDURE, tp);
+			{ *ptp = construct_type(PROCVAR, tp);
 			  (*ptp)->prc_params = pr;
 			}
 ;

lang/m2/comp/def.H

@@ -3,14 +3,14 @@
 /* $Header$ */
 
 struct module {
-	int mo_priority;	/* Priority of a module */
+	int mo_priority;	/* priority of a module */
-	int mo_scope;		/* Scope of this module */
+	int mo_scope;		/* scope of this module */
 #define mod_priority	df_value.df_module.mo_priority
 #define mod_scope	df_value.df_module.mo_scope
 };
 
 struct variable {
-	arith va_off;		/* Address or offset of variable */
+	arith va_off;		/* address or offset of variable */
 #define var_off		df_value.df_variable.va_off
 };
 
@@ -20,8 +20,8 @@ struct constant {
 };
 
 struct enumval {
-	unsigned int en_val;	/* Value of this enumeration literal */
+	unsigned int en_val;	/* value of this enumeration literal */
-	struct def *en_next;	/* Next 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
 };
@@ -37,8 +37,13 @@ struct field {
 #define fld_variant	df_value.df_field.fd_variant
 };
 
+struct dfproc {
+	int pr_scope;		/* scope number of procedure */
+#define prc_scope	df_value.df_proc.pr_scope
+};
+
 struct import {
-	struct def *im_def;	/* Scope number from which imported */
+	struct def *im_def;	/* imported definition */
 #define imp_def		df_value.df_import.im_def
 };
 
@@ -47,32 +52,33 @@ struct def	{		/* list of definitions for a name */
 	struct def *df_nextinscope;
 				/* link all definitions in a scope */
 	struct idf *df_idf;	/* link back to the name */
-	int df_scope;		/* Scope in which this definition resides */
+	int df_scope;		/* scope in which this definition resides */
-	short df_kind;		/* The kind of this definition: */
+	short df_kind;		/* the kind of this definition: */
-#define D_MODULE	0x0001	/* A module */
+#define D_MODULE	0x0001	/* a module */
-#define D_PROCEDURE	0x0002	/* Procedure of function */
+#define D_PROCEDURE	0x0002	/* procedure of function */
-#define D_VARIABLE	0x0004	/* A variable */
+#define D_VARIABLE	0x0004	/* a variable */
-#define D_FIELD		0x0008	/* A field in a record */
+#define D_FIELD		0x0008	/* a field in a record */
-#define D_TYPE		0x0010	/* A type */
+#define D_TYPE		0x0010	/* a type */
-#define D_ENUM		0x0020	/* An enumeration literal */
+#define D_ENUM		0x0020	/* an enumeration literal */
-#define D_CONST		0x0040	/* A constant */
+#define D_CONST		0x0040	/* a constant */
-#define D_IMPORT	0x0080	/* An imported definition */
+#define D_IMPORT	0x0080	/* an imported definition */
-#define D_PROCHEAD	0x0100	/* A procedure heading in a definition module */
+#define D_PROCHEAD	0x0100	/* a procedure heading in a definition module */
-#define D_HIDDEN	0x0200	/* A hidden type */
+#define D_HIDDEN	0x0200	/* a hidden type */
-#define D_HTYPE		0x0400	/* Definition of a hidden type seen */
+#define D_HTYPE		0x0400	/* definition of a hidden type seen */
-#define D_STDPROC	0x0800	/* A standard procedure */
+#define D_STDPROC	0x0800	/* a standard procedure */
-#define D_STDFUNC	0x1000	/* A standard function */
+#define D_STDFUNC	0x1000	/* a standard function */
-#define D_ERROR		0x2000	/* A compiler generated definition for an
+#define D_ERROR		0x2000	/* a compiler generated definition for an
 				   undefined variable
 				*/
-#define D_ISEXPORTED	0x4000	/* Not yet defined */
+#define D_ISEXPORTED	0x4000	/* not yet defined */
 	char df_flags;
-#define D_ADDRESS	0x01	/* Set if address was taken */
+#define D_ADDRESS	0x01	/* set if address was taken */
-#define D_USED		0x02	/* Set if used */
+#define D_USED		0x02	/* set if used */
-#define D_DEFINED	0x04	/* Set if it is assigned a value */
+#define D_DEFINED	0x04	/* set if it is assigned a value */
-#define D_VARPAR	0x08	/* Set if it is a VAR parameter */
+#define D_VARPAR	0x08	/* set if it is a VAR parameter */
-#define D_EXPORTED	0x40	/* Set if exported */
+#define D_VALPAR	0x10	/* set if it is a value parameter */
-#define D_QEXPORTED	0x80	/* Set if qualified exported */
+#define D_EXPORTED	0x40	/* set if exported */
+#define D_QEXPORTED	0x80	/* set if qualified exported */
 	struct type *df_type;
 	union {
 		struct module df_module;
@@ -81,7 +87,8 @@ 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 */
+		struct dfproc df_proc;
+		int df_stdname;	/* define for standard name */
 	} df_value;
 };
 

lang/m2/comp/defmodule.c

@@ -1,5 +1,7 @@
 /* D E F I N I T I O N   M O D U L E S */
 
+static char *RcsId = "$Header$";
+
 #include	<assert.h>
 #include	<em_arith.h>
 #include	<em_label.h>

lang/m2/comp/tokenname.c

@@ -76,6 +76,10 @@ struct tokenname tkidf[] =	{	/* names of the identifier tokens */
 
 struct tokenname tkinternal[] = {	/* internal keywords	*/
 	{PROGRAM, ""},
+	{SUBRANGE, ""},
+	{ENUMERATION, ""},
+	{ERRONEOUS, ""},
+	{PROCVAR, ""},
 	{0, "0"}
 };
 
@@ -85,9 +89,6 @@ struct tokenname tkstandard[] =	{	/* standard identifiers */
 	{LONGINT, ""},
 	{CARDINAL, ""},
 	{LONGREAL, ""},
-	{SUBRANGE, ""},
-	{ENUMERATION, ""},
-	{ERRONEOUS, ""},
 	{WORD, ""},
 	{ADDRESS, ""},
 	{0, ""}

lang/m2/comp/typequiv.c

@@ -0,0 +1,54 @@
+/* T Y P E   E Q U I V A L E N C E */
+
+static char *RcsId = "$Header$";
+
+#include	<em_arith.h>
+#include	<em_label.h>
+#include	"type.h"
+#include	"def.h"
+#include	"Lpars.h"
+
+int
+TstTypeEquiv(tp1, tp2)
+	register struct type *tp1, *tp2;
+{
+	/*	test if two types are equivalent. The only complication comes
+		from the fact that for some procedures two declarations may
+		be given: one in the specification module and one in the
+		definition module.
+	*/
+
+	return     tp1 == tp2
+		||
+		   ( 
+		     tp1 && tp1->tp_fund == PROCEDURE
+		   &&
+		     tp2 && tp2->tp_fund == PROCEDURE
+		   &&
+		     TstProcEquiv(tp1, tp2)
+		   );
+
+}
+
+int
+TstProcEquiv(tp1, tp2)
+	register 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;
+
+	if (!TstTypeEquiv(tp1->next, tp2->next)) return 0;
+	p1 = tp1->prc_params;
+	p2 = tp2->prc_params;
+	while (p1 && p2) {
+		if (p1->par_var != p2->par_var ||
+		    !TstTypeEquiv(p1->par_type, p2->par_type)) return 0;
+		p1 = p1->next;
+		p2 = p2->next;
+	}
+	if (p1 != p2) return 0;
+	return 1;
+}