From 0e4311490c43a842925a32b11eae2ba19b55348e Mon Sep 17 00:00:00 2001 From: ceriel Date: Fri, 4 Apr 1986 13:47:04 +0000 Subject: [PATCH] A newer version --- lang/m2/comp/LLlex.c | 26 +++++++++------- lang/m2/comp/LLlex.h | 19 +++++++----- lang/m2/comp/LLmessage.c | 2 +- lang/m2/comp/Makefile | 3 +- lang/m2/comp/declar.g | 30 +++++++++++++++--- lang/m2/comp/def.H | 67 ++++++++++++++++++++++------------------ lang/m2/comp/defmodule.c | 2 ++ lang/m2/comp/tokenname.c | 7 +++-- lang/m2/comp/typequiv.c | 54 ++++++++++++++++++++++++++++++++ 9 files changed, 152 insertions(+), 58 deletions(-) create mode 100644 lang/m2/comp/typequiv.c diff --git a/lang/m2/comp/LLlex.c b/lang/m2/comp/LLlex.c index 0eaa1730e..91817c101 100644 --- a/lang/m2/comp/LLlex.c +++ b/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; - char *str = Malloc(str_size = 32); - register int pos = 0; + register struct string *str = &string; + register char *p; + 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; - if (pos == str_size) { - str = Srealloc(str, str_size += 8); + *p++ = ch; + if (p - str->s_str == str->s_length) { + str->s_str = Srealloc(str->s_str, str->s_length += 8); + p = str->s_str + (str->s_length - 8); } LoadChar(ch); } - str[pos] = '\0'; - return str; + *p = '\0'; + 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: diff --git a/lang/m2/comp/LLlex.h b/lang/m2/comp/LLlex.h index 65690fd3b..92bc5979e 100644 --- a/lang/m2/comp/LLlex.h +++ b/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 { /* INTEGER */ - struct type *tk_type; /* type */ - arith tk_value; /* value */ - } tk_int; + struct string tk_str; /* STRING */ + arith tk_int; /* INTEGER */ char *tk_real; /* REAL */ } tk_data; }; #define TOK_IDF tk_data.tk_idf -#define TOK_STR tk_data.tk_str -#define TOK_ITP tk_data.tk_int.tk_type -#define TOK_INT tk_data.tk_int.tk_value +#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; diff --git a/lang/m2/comp/LLmessage.c b/lang/m2/comp/LLmessage.c index 85591d602..ad6cd5be7 100644 --- a/lang/m2/comp/LLmessage.c +++ b/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: diff --git a/lang/m2/comp/Makefile b/lang/m2/comp/Makefile index 211f60ec7..2bff6e5ed 100644 --- a/lang/m2/comp/Makefile +++ b/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 diff --git a/lang/m2/comp/declar.g b/lang/m2/comp/declar.g index b773b6cce..1db02dbc9 100644 --- a/lang/m2/comp/declar.g +++ b/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_PROCEDURE) { + if (type == D_PROCHEAD) { + 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, ¶ms, &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; } ; diff --git a/lang/m2/comp/def.H b/lang/m2/comp/def.H index 3bc322606..99c34b9c1 100644 --- a/lang/m2/comp/def.H +++ b/lang/m2/comp/def.H @@ -3,14 +3,14 @@ /* $Header$ */ struct module { - int mo_priority; /* Priority of a module */ - int mo_scope; /* Scope of this module */ + int mo_priority; /* priority of a 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 */ - struct def *en_next; /* Next enumeration literal */ + unsigned int 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 }; @@ -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 */ - 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_HTYPE 0x0400 /* Definition of a hidden type seen */ -#define D_STDPROC 0x0800 /* A standard procedure */ -#define D_STDFUNC 0x1000 /* A standard function */ -#define D_ERROR 0x2000 /* A compiler generated definition for an + int df_scope; /* scope in which this definition resides */ + 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_HTYPE 0x0400 /* definition of a hidden type seen */ +#define D_STDPROC 0x0800 /* a standard procedure */ +#define D_STDFUNC 0x1000 /* a standard function */ +#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_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 */ +#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_VALPAR 0x10 /* set if it is a value 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; @@ -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; }; diff --git a/lang/m2/comp/defmodule.c b/lang/m2/comp/defmodule.c index b007705dc..b781adc6c 100644 --- a/lang/m2/comp/defmodule.c +++ b/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 #include #include diff --git a/lang/m2/comp/tokenname.c b/lang/m2/comp/tokenname.c index 10c28ac87..b4ce2b5c8 100644 --- a/lang/m2/comp/tokenname.c +++ b/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, ""} diff --git a/lang/m2/comp/typequiv.c b/lang/m2/comp/typequiv.c new file mode 100644 index 000000000..96f9e38a6 --- /dev/null +++ b/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 +#include +#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; +} -- 2.34.1