From 7f174a46c35d3375b32816d95f2e2e811255ea41 Mon Sep 17 00:00:00 2001 From: ceriel Date: Wed, 26 Mar 1986 15:11:02 +0000 Subject: [PATCH] A newer version, safety commit --- lang/m2/comp/LLlex.c | 25 +++-- lang/m2/comp/LLlex.h | 6 +- lang/m2/comp/LLmessage.c | 31 ++---- lang/m2/comp/Makefile | 25 +++-- lang/m2/comp/class.h | 2 +- lang/m2/comp/declar.g | 74 ++++++++++--- lang/m2/comp/def.H | 75 ++++++++++++++ lang/m2/comp/def.c | 83 +++++++++++++++ lang/m2/comp/def_sizes.h | 22 ++++ lang/m2/comp/error.c | 219 +++++++++++++++++++++++---------------- lang/m2/comp/f_info.h | 2 + lang/m2/comp/idf.c | 2 + lang/m2/comp/idf.h | 13 ++- lang/m2/comp/input.c | 2 + lang/m2/comp/input.h | 2 + lang/m2/comp/main.c | 40 ++++--- lang/m2/comp/main.h | 8 ++ lang/m2/comp/misc.H | 12 +++ lang/m2/comp/misc.c | 63 +++++++++++ lang/m2/comp/print.c | 144 +++++++++++++++++++++++++ lang/m2/comp/program.g | 64 ++++++------ lang/m2/comp/scope.C | 62 +++++++++++ lang/m2/comp/scope.h | 19 ++++ lang/m2/comp/statement.g | 2 + lang/m2/comp/tokenname.c | 20 +++- lang/m2/comp/tokenname.h | 3 + lang/m2/comp/type.H | 90 ++++++++++++++++ lang/m2/comp/type.c | 134 ++++++++++++++++++++++++ 28 files changed, 1028 insertions(+), 216 deletions(-) create mode 100644 lang/m2/comp/def.H create mode 100644 lang/m2/comp/def.c create mode 100644 lang/m2/comp/def_sizes.h create mode 100644 lang/m2/comp/main.h create mode 100644 lang/m2/comp/misc.H create mode 100644 lang/m2/comp/misc.c create mode 100644 lang/m2/comp/print.c create mode 100644 lang/m2/comp/scope.C create mode 100644 lang/m2/comp/scope.h create mode 100644 lang/m2/comp/type.H create mode 100644 lang/m2/comp/type.c diff --git a/lang/m2/comp/LLlex.c b/lang/m2/comp/LLlex.c index 17c92ad2c..a67701088 100644 --- a/lang/m2/comp/LLlex.c +++ b/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 -#include "f_info.h" -#include "Lpars.h" -#include "class.h" -#include "param.h" -#include "idf.h" -#include "LLlex.h" +static char *RcsId = "$Header$"; + +#include +#include +#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. */ diff --git a/lang/m2/comp/LLlex.h b/lang/m2/comp/LLlex.h index 594a0cf52..65690fd3b 100644 --- a/lang/m2/comp/LLlex.h +++ b/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; diff --git a/lang/m2/comp/LLmessage.c b/lang/m2/comp/LLmessage.c index fe10602be..85591d602 100644 --- a/lang/m2/comp/LLmessage.c +++ b/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 -#include "f_info.h" +#include #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; { diff --git a/lang/m2/comp/Makefile b/lang/m2/comp/Makefile index e0c745953..8fc8d53f0 100644 --- a/lang/m2/comp/Makefile +++ b/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 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 diff --git a/lang/m2/comp/class.h b/lang/m2/comp/class.h index 322ac0509..72341981c 100644 --- a/lang/m2/comp/class.h +++ b/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$ */ diff --git a/lang/m2/comp/declar.g b/lang/m2/comp/declar.g index c3cc67c9d..721747673 100644 --- a/lang/m2/comp/declar.g +++ b/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$"; -} -ProcedureDeclaration: - ProcedureHeading ';' block IDENT -; +#include +#include +#include "idf.h" +#include "misc.h" +#include "LLlex.h" +#include "def.h" +#include "type.h" +#include "scope.h" +} -ProcedureHeading: - PROCEDURE IDENT FormalParameters? +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 +{ + 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 diff --git a/lang/m2/comp/def.H b/lang/m2/comp/def.H new file mode 100644 index 000000000..21fe8cd22 --- /dev/null +++ b/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(); diff --git a/lang/m2/comp/def.c b/lang/m2/comp/def.c new file mode 100644 index 000000000..100cbad54 --- /dev/null +++ b/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 +#include +#include +#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; +} diff --git a/lang/m2/comp/def_sizes.h b/lang/m2/comp/def_sizes.h new file mode 100644 index 000000000..a8543f8b2 --- /dev/null +++ b/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 diff --git a/lang/m2/comp/error.c b/lang/m2/comp/error.c index 3e04da2e0..4a853a443 100644 --- a/lang/m2/comp/error.c +++ b/lang/m2/comp/error.c @@ -1,170 +1,205 @@ -/* 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 +static char *RcsId = "$Header$"; + +#include +#include #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. */ -/*VARARGS1*/ -error(fmt, args) +#ifdef DEBUG +/*VARARGS2*/ +debug(level, fmt, args) char *fmt; { - /* - if (compiling) - C_ms_err(); - */ - ++err_occurred; - _error(ERROR, fmt, &args); + if (level <= options['D']) _error(VDEBUG, NILEXPR, fmt, &args); } +#endif DEBUG -#ifdef DEBUG -debug(fmt, args) +/*VARARGS1*/ +error(fmt, args) char *fmt; { - if (options['D']) - _error(VDEBUG, fmt, &args); + _error(ERROR, NILEXPR, fmt, &args); } -#endif DEBUG -/*VARARGS1*/ -lexerror(fmt, args) +/*VARARGS2*/ +expr_error(expr, fmt, args) + struct expr *expr; char *fmt; { - /* - if (compiling) - C_ms_err(); - */ - ++err_occurred; - _error(LEXERROR, fmt, &args); + _error(ERROR, expr, fmt, &args); } /*VARARGS1*/ -lexwarning(fmt, args) char *fmt; { - if (options['w']) return; - _error(LEXWARNING, fmt, &args); +warning(fmt, args) + char *fmt; +{ + _error(WARNING, NILEXPR, fmt, &args); } -/*VARARGS1*/ -crash(fmt, args) +/*VARARGS2*/ +expr_warning(expr, fmt, args) + struct expr *expr; 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(WARNING, expr, fmt, &args); } /*VARARGS1*/ -fatal(fmt, args) +lexerror(fmt, args) char *fmt; - int args; { - /* - if (compiling) - C_ms_err(); - */ - _error(FATAL, fmt, &args); - exit(-1); + _error(LEXERROR, NILEXPR, fmt, &args); } /*VARARGS1*/ -nonfatal(fmt, args) +lexwarning(fmt, args) char *fmt; - int args; { - _error(NONFATAL, fmt, &args); + _error(LEXWARNING, NILEXPR, fmt, &args); } /*VARARGS1*/ -warning(fmt, args) +fatal(fmt, args) char *fmt; + int args; { - if (options['w']) return; - _error(WARNING, fmt, &args); + + _error(FATAL, NILEXPR, fmt, &args); + sys_stop(S_EXIT); } -_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: + if (options['w']) + return; break; + } + + /* the remark */ + switch (class) { case WARNING: case LEXWARNING: - fprintf(ERROUT, "%s, line %ld: (warning) ", - FileName, LineNumber); + 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 ??? */ + } + + /* the place */ + switch (class) { + case WARNING: + case ERROR: + ln = /* expr ? expr->ex_line : */ dot.tk_lineno; break; -#ifdef DEBUG - case VDEBUG: - fprintf(ERROUT, "-D "); + case LEXWARNING: + case LEXERROR: + case CRASH: + case FATAL: + ln = LineNumber; break; -#endif DEBUG } - _doprnt(fmt, argv, ERROUT); + +#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"); } diff --git a/lang/m2/comp/f_info.h b/lang/m2/comp/f_info.h index c04496ad9..92b1710a4 100644 --- a/lang/m2/comp/f_info.h +++ b/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 { diff --git a/lang/m2/comp/idf.c b/lang/m2/comp/idf.c index d1b0380a2..3f59640a7 100644 --- a/lang/m2/comp/idf.c +++ b/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" diff --git a/lang/m2/comp/idf.h b/lang/m2/comp/idf.h index 46f7af0e4..60322ff4f 100644 --- a/lang/m2/comp/idf.h +++ b/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 diff --git a/lang/m2/comp/input.c b/lang/m2/comp/input.c index a55c4fd58..bc6088858 100644 --- a/lang/m2/comp/input.c +++ b/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" diff --git a/lang/m2/comp/input.h b/lang/m2/comp/input.h index 3fcb7b8b8..aa28ffc1a 100644 --- a/lang/m2/comp/input.h +++ b/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 diff --git a/lang/m2/comp/main.c b/lang/m2/comp/main.c index b0cfbc3f6..811118ab8 100644 --- a/lang/m2/comp/main.c +++ b/lang/m2/comp/main.c @@ -1,18 +1,20 @@ -/* mod2 -- compiler , althans: een aanzet daartoe */ - -#include -#undef BUFSIZ /* Really neccesary??? */ -#include -#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 +#include +#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 */ } diff --git a/lang/m2/comp/main.h b/lang/m2/comp/main.h new file mode 100644 index 000000000..884d2b345 --- /dev/null +++ b/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 + */ diff --git a/lang/m2/comp/misc.H b/lang/m2/comp/misc.H new file mode 100644 index 000000000..5ca8a003d --- /dev/null +++ b/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" */ diff --git a/lang/m2/comp/misc.c b/lang/m2/comp/misc.c new file mode 100644 index 000000000..7afd72023 --- /dev/null +++ b/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 +#include +#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] == '#'; +} diff --git a/lang/m2/comp/print.c b/lang/m2/comp/print.c new file mode 100644 index 000000000..ffb1a725d --- /dev/null +++ b/lang/m2/comp/print.c @@ -0,0 +1,144 @@ +/* P R I N T R O U T I N E S */ + +#include +#include + +#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 = ""; + + /* 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; +} diff --git a/lang/m2/comp/program.g b/lang/m2/comp/program.g index 89eef00a7..00c2c82fc 100644 --- a/lang/m2/comp/program.g +++ b/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 +#include +#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: diff --git a/lang/m2/comp/scope.C b/lang/m2/comp/scope.C new file mode 100644 index 000000000..63cbdb773 --- /dev/null +++ b/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 +#include +#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; +} diff --git a/lang/m2/comp/scope.h b/lang/m2/comp/scope.h new file mode 100644 index 000000000..a1caef49e --- /dev/null +++ b/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) diff --git a/lang/m2/comp/statement.g b/lang/m2/comp/statement.g index 3e736a5ae..70e7b8095 100644 --- a/lang/m2/comp/statement.g +++ b/lang/m2/comp/statement.g @@ -1,3 +1,5 @@ +/* S T A T E M E N T S */ + { static char *RcsId = "$Header$"; } diff --git a/lang/m2/comp/tokenname.c b/lang/m2/comp/tokenname.c index 32e658a1f..e18ff871a 100644 --- a/lang/m2/comp/tokenname.c +++ b/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, ""} }; diff --git a/lang/m2/comp/tokenname.h b/lang/m2/comp/tokenname.h index 2b545da45..7838ae874 100644 --- a/lang/m2/comp/tokenname.h +++ b/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 */ diff --git a/lang/m2/comp/type.H b/lang/m2/comp/type.H new file mode 100644 index 000000000..6b76f1bb7 --- /dev/null +++ b/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(); diff --git a/lang/m2/comp/type.c b/lang/m2/comp/type.c new file mode 100644 index 000000000..856a5c05c --- /dev/null +++ b/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 +#include +#include +#include +#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); +} -- 2.34.1