-/* 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 <alloc.h>
-#include "f_info.h"
-#include "Lpars.h"
-#include "class.h"
-#include "param.h"
-#include "idf.h"
-#include "LLlex.h"
+static char *RcsId = "$Header$";
+
+#include <alloc.h>
+#include <em_arith.h>
+#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.
*/
-/* 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$ */
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;
+/* 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 <alloc.h>
-#include "f_info.h"
+#include <em_arith.h>
#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)
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;
{
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 \
symbol2str.c: tokenname.c make.tokcase
make.tokcase <tokenname.c >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
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
-/* 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$ */
-{
-#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 <em_arith.h>
+#include <em_label.h>
+#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:
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:
[ ':' qualident ]?
;
-ConstantDeclaration:
- IDENT '=' ConstExpression
+ConstantDeclaration
+{
+ register struct def *df;
+}:
+ IDENT { df = define(dot.TOK_IDF, CurrentScope, D_CONST); }
+ '=' ConstExpression
;
VariableDeclaration
--- /dev/null
+/* 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();
--- /dev/null
+/* D E F I N I T I O N M E C H A N I S M */
+
+static char *RcsId = "$Header$";
+
+#include <alloc.h>
+#include <em_arith.h>
+#include <em_label.h>
+#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;
+}
--- /dev/null
+/* 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
-/* 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 <stdio.h>
+static char *RcsId = "$Header$";
+
+#include <system.h>
+#include <em_arith.h>
#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");
}
+/* 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 {
+/* 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"
+/* 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 <idf_pkg.spec>
+/* 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"
+/* 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
-/* mod2 -- compiler , althans: een aanzet daartoe */
-
-#include <stdio.h>
-#undef BUFSIZ /* Really neccesary??? */
-#include <system.h>
-#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 <system.h>
+#include <em_arith.h>
+#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)
ProgName = *argv++;
-# ifdef DEBUG
- setbuf(stdout, (char *) 0);
-# endif
while (--argc > 0) {
if (**argv == '-')
Option(*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]);
}
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();
{
register int symb;
- while ((symb = LLlex()) != EOF) {
+ while ((symb = LLlex()) != EOI) {
printf(">>> %s ", symbol2str(symb));
switch(symb) {
}
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 */
}
--- /dev/null
+/* 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
+ */
--- /dev/null
+/* 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" */
--- /dev/null
+/* 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 <alloc.h>
+#include <em_arith.h>
+#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] == '#';
+}
--- /dev/null
+/* P R I N T R O U T I N E S */
+
+#include <system.h>
+#include <em_arith.h>
+
+#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 = "<bad format>";
+
+ /* 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;
+}
-/*
- 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 <alloc.h>
+#include <em_arith.h>
+#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
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:
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) ';'
/*
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 '.'
;
;
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:
--- /dev/null
+/* S C O P E M E C H A N I S M */
+
+static char *RcsId = "$Header$";
+
+#include <assert.h>
+#include <alloc.h>
+#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;
+}
--- /dev/null
+/* 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)
+/* S T A T E M E N T S */
+
{
static char *RcsId = "$Header$";
}
-#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
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"},
};
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, ""}
};
+/* 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
*/
--- /dev/null
+/* 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();
--- /dev/null
+/* 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 <assert.h>
+#include <alloc.h>
+#include <em_arith.h>
+#include <em_label.h>
+#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);
+}
public / ack.git / commitdiff