d0p1/ack
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

A newer version, safety commit

Browse source
This commit is contained in:
ceriel 1986-03-26 15:11:02 +00:00
parent 8546fbe868
commit 7f174a46c3
28 changed files with 1034 additions and 222 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

25
lang/m2/comp/LLlex.c
View file

@ -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 <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.
*/

6
lang/m2/comp/LLlex.h
View file

@ -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;

31
lang/m2/comp/LLmessage.c
View file

@ -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 <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)
@ -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;
{

25
lang/m2/comp/Makefile
View file

@ -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 <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
@ -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

2
lang/m2/comp/class.h
View file

@ -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$ */

70
lang/m2/comp/declar.g
View file

@ -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$";
#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"
}
ProcedureDeclaration:
ProcedureHeading ';' block IDENT
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:
PROCEDURE IDENT FormalParameters?
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

75
lang/m2/comp/def.H Normal file
View file

@ -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();

83
lang/m2/comp/def.c Normal file
View file

@ -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 <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;
}

22
lang/m2/comp/def_sizes.h Normal file
View file

@ -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

233
lang/m2/comp/error.c
View file

@ -1,105 +1,101 @@
/* 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.
*/
#ifdef DEBUG
/*VARARGS2*/
debug(level, fmt, args)
char *fmt;
{
if (level <= options['D']) _error(VDEBUG, NILEXPR, fmt, &args);
}
#endif DEBUG
/*VARARGS1*/
error(fmt, args)
char *fmt;
{
/*
if (compiling)
C_ms_err();
*/
++err_occurred;
_error(ERROR, fmt, &args);
_error(ERROR, NILEXPR, fmt, &args);
}
#ifdef DEBUG
debug(fmt, args)
/*VARARGS2*/
expr_error(expr, fmt, args)
struct expr *expr;
char *fmt;
{
if (options['D'])
_error(VDEBUG, fmt, &args);
_error(ERROR, expr, fmt, &args);
}
/*VARARGS1*/
warning(fmt, args)
char *fmt;
{
_error(WARNING, NILEXPR, fmt, &args);
}
/*VARARGS2*/
expr_warning(expr, fmt, args)
struct expr *expr;
char *fmt;
{
_error(WARNING, expr, fmt, &args);
}
#endif DEBUG
/*VARARGS1*/
lexerror(fmt, args)
char *fmt;
{
/*
if (compiling)
C_ms_err();
*/
++err_occurred;
_error(LEXERROR, fmt, &args);
_error(LEXERROR, NILEXPR, fmt, &args);
}
/*VARARGS1*/
lexwarning(fmt, args) char *fmt; {
if (options['w']) return;
_error(LEXWARNING, fmt, &args);
}
/*VARARGS1*/
crash(fmt, args)
lexwarning(fmt, args)
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(LEXWARNING, NILEXPR, fmt, &args);
}
/*VARARGS1*/
@ -107,64 +103,103 @@ fatal(fmt, args)
char *fmt;
int args;
{
/*
if (compiling)
C_ms_err();
*/
_error(FATAL, fmt, &args);
exit(-1);
_error(FATAL, NILEXPR, fmt, &args);
sys_stop(S_EXIT);
}
/*VARARGS1*/
nonfatal(fmt, args)
char *fmt;
int args;
{
_error(NONFATAL, fmt, &args);
}
/*VARARGS1*/
warning(fmt, args)
char *fmt;
{
if (options['w']) return;
_error(WARNING, fmt, &args);
}
_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:
fprintf(ERROUT, "%s, line %ld: (warning) ",
FileName, LineNumber);
if (options['w'])
return;
break;
}
/* the remark */
switch (class) {
case WARNING:
case LEXWARNING:
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 ??? */
break;
#ifdef DEBUG
case VDEBUG:
fprintf(ERROUT, "-D ");
break;
#endif DEBUG
}
_doprnt(fmt, argv, ERROUT);
/* the place */
switch (class) {
case WARNING:
case ERROR:
ln = /* expr ? expr->ex_line : */ dot.tk_lineno;
break;
case LEXWARNING:
case LEXERROR:
case CRASH:
case FATAL:
ln = LineNumber;
break;
}
#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");
}

2
lang/m2/comp/f_info.h
View file

@ -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 {

2
lang/m2/comp/idf.c
View file

@ -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"

13
lang/m2/comp/idf.h
View file

@ -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 <idf_pkg.spec>

2
lang/m2/comp/input.c
View file

@ -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"

2
lang/m2/comp/input.h
View file

@ -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

40
lang/m2/comp/main.c
View file

@ -1,18 +1,20 @@
/* 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)
@ -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 */
}

8
lang/m2/comp/main.h Normal file
View file

@ -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
*/

12
lang/m2/comp/misc.H Normal file
View file

@ -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" */

63
lang/m2/comp/misc.c Normal file
View file

@ -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 <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] == '#';
}

144
lang/m2/comp/print.c Normal file
View file

@ -0,0 +1,144 @@
/* 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;
}

64
lang/m2/comp/program.g
View file

@ -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 <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
@ -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:

62
lang/m2/comp/scope.C Normal file
View file

@ -0,0 +1,62 @@
/* 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;
}

19
lang/m2/comp/scope.h Normal file
View file

@ -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)

2
lang/m2/comp/statement.g
View file

@ -1,3 +1,5 @@
/* S T A T E M E N T S */
{
static char *RcsId = "$Header$";
}

20
lang/m2/comp/tokenname.c
View file

@ -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, ""}
};

3
lang/m2/comp/tokenname.h
View file

@ -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
*/

90
lang/m2/comp/type.H Normal file
View file

@ -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();

134
lang/m2/comp/type.c Normal file
View file

@ -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 <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);
}