Initial version
This commit is contained in:
parent
9f8f8c1a9c
commit
b683a21217
383
lang/m2/comp/LLlex.c
Normal file
383
lang/m2/comp/LLlex.c
Normal file
|
@ -0,0 +1,383 @@
|
|||
/* LEXICAL ANALYSER FOR MODULA-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"
|
||||
|
||||
long str2long();
|
||||
char *GetString();
|
||||
|
||||
struct token dot, aside;
|
||||
|
||||
static char *RcsId = "$Header$";
|
||||
|
||||
int
|
||||
LLlex()
|
||||
{
|
||||
/* LLlex() plays the role of Lexical Analyzer for the parser.
|
||||
The putting aside of tokens is taken into account.
|
||||
*/
|
||||
if (ASIDE) { /* a token is put aside */
|
||||
dot = aside;
|
||||
ASIDE = 0;
|
||||
}
|
||||
else {
|
||||
GetToken(&dot);
|
||||
if (DOT == EOI) DOT = -1;
|
||||
}
|
||||
|
||||
return DOT;
|
||||
}
|
||||
|
||||
int
|
||||
GetToken(tk)
|
||||
register struct token *tk;
|
||||
{
|
||||
char buf[(IDFSIZE > NUMSIZE ? IDFSIZE : NUMSIZE) + 1];
|
||||
register int ch, nch;
|
||||
|
||||
again:
|
||||
LoadChar(ch);
|
||||
if ((ch & 0200) && ch != EOI) {
|
||||
fatal("non-ascii '\\%03o' read", ch & 0377);
|
||||
}
|
||||
|
||||
switch (class(ch)) {
|
||||
|
||||
case STSKIP:
|
||||
goto again;
|
||||
|
||||
case STNL:
|
||||
LineNumber++;
|
||||
goto again;
|
||||
|
||||
case STGARB:
|
||||
if (040 < ch && ch < 0177) {
|
||||
lexerror("garbage char %c", ch);
|
||||
}
|
||||
else {
|
||||
lexerror("garbage char \\%03o", ch);
|
||||
}
|
||||
goto again;
|
||||
|
||||
case STSIMP:
|
||||
if (ch == '(') {
|
||||
LoadChar(nch);
|
||||
if (nch == '*') {
|
||||
SkipComment();
|
||||
goto again;
|
||||
}
|
||||
else {
|
||||
PushBack(nch);
|
||||
}
|
||||
}
|
||||
return tk->tk_symb = ch;
|
||||
|
||||
case STCOMP:
|
||||
LoadChar(nch);
|
||||
switch (ch) {
|
||||
|
||||
case '.':
|
||||
if (nch == '.') {
|
||||
return tk->tk_symb = UPTO;
|
||||
}
|
||||
PushBack(nch);
|
||||
return tk->tk_symb = ch;
|
||||
|
||||
case ':':
|
||||
if (nch == '=') {
|
||||
return tk->tk_symb = BECOMES;
|
||||
}
|
||||
PushBack(nch);
|
||||
return tk->tk_symb = ch;
|
||||
|
||||
case '<':
|
||||
if (nch == '=') {
|
||||
return tk->tk_symb = LESSEQUAL;
|
||||
}
|
||||
else
|
||||
if (nch == '>') {
|
||||
return tk->tk_symb = UNEQUAL;
|
||||
}
|
||||
PushBack(nch);
|
||||
return tk->tk_symb = ch;
|
||||
|
||||
case '>':
|
||||
if (nch == '=') {
|
||||
return tk->tk_symb = GREATEREQUAL;
|
||||
}
|
||||
PushBack(nch);
|
||||
return tk->tk_symb = ch;
|
||||
|
||||
default :
|
||||
crash("bad STCOMP");
|
||||
}
|
||||
|
||||
case STIDF:
|
||||
{
|
||||
register char *tg = &buf[0];
|
||||
register struct idf *id;
|
||||
|
||||
do {
|
||||
if (tg - buf < IDFSIZE) *tg++ = ch;
|
||||
LoadChar(ch);
|
||||
} while(in_idf(ch));
|
||||
|
||||
if (ch != EOI)
|
||||
PushBack(ch);
|
||||
*tg++ = '\0';
|
||||
|
||||
id = tk->TOK_IDF = str2idf(buf, 1);
|
||||
if (!id) fatal("Out of memory");
|
||||
return tk->tk_symb = id->id_reserved ? id->id_reserved : IDENT;
|
||||
}
|
||||
|
||||
case STSTR:
|
||||
tk->TOK_STR = GetString(ch);
|
||||
return tk->tk_symb = STRING;
|
||||
|
||||
case STNUM:
|
||||
{
|
||||
/* The problem arising with the "parsing" of a number
|
||||
is that we don't know the base in advance so we
|
||||
have to read the number with the help of a rather
|
||||
complex finite automaton.
|
||||
Excuses for the very ugly code!
|
||||
*/
|
||||
register char *np = &buf[1];
|
||||
/* allow a '-' to be added */
|
||||
|
||||
*np++ = ch;
|
||||
|
||||
LoadChar(ch);
|
||||
while (is_oct(ch)) {
|
||||
if (np < &buf[NUMSIZE]) {
|
||||
*np++ = ch;
|
||||
}
|
||||
LoadChar(ch);
|
||||
}
|
||||
switch (ch) {
|
||||
case 'H':
|
||||
Shex: *np++ = '\0';
|
||||
/* Type is integer */
|
||||
tk->TOK_INT = str2long(&buf[1], 16);
|
||||
return tk->tk_symb = INTEGER;
|
||||
|
||||
case '8':
|
||||
case '9':
|
||||
do {
|
||||
if (np < &buf[NUMSIZE]) {
|
||||
*np++ = ch;
|
||||
}
|
||||
LoadChar(ch);
|
||||
} while (is_dig(ch));
|
||||
|
||||
if (is_hex(ch))
|
||||
goto S2;
|
||||
if (ch == 'H')
|
||||
goto Shex;
|
||||
if (ch == '.')
|
||||
goto Sreal;
|
||||
PushBack(ch);
|
||||
goto Sdec;
|
||||
|
||||
case 'B':
|
||||
case 'C':
|
||||
if (np < &buf[NUMSIZE]) {
|
||||
*np++ = ch;
|
||||
}
|
||||
LoadChar(ch);
|
||||
if (ch == 'H')
|
||||
goto Shex;
|
||||
if (is_hex(ch))
|
||||
goto S2;
|
||||
PushBack(ch);
|
||||
ch = *--np;
|
||||
*np++ = '\0';
|
||||
/*
|
||||
* If (ch == 'C') type is a CHAR
|
||||
* else type is an INTEGER
|
||||
*/
|
||||
tk->TOK_INT = str2long(&buf[1], 8);
|
||||
return tk->tk_symb = INTEGER;
|
||||
|
||||
case 'A':
|
||||
case 'D':
|
||||
case 'E':
|
||||
case 'F':
|
||||
S2:
|
||||
do {
|
||||
if (np < &buf[NUMSIZE]) {
|
||||
*np++ = ch;
|
||||
}
|
||||
LoadChar(ch);
|
||||
} while (is_hex(ch));
|
||||
if (ch != 'H') {
|
||||
lexerror("H expected after hex number");
|
||||
PushBack(ch);
|
||||
}
|
||||
goto Shex;
|
||||
|
||||
case '.':
|
||||
Sreal:
|
||||
/* This '.' could be the first of the '..'
|
||||
token. At this point, we need a look-ahead
|
||||
of two characters.
|
||||
*/
|
||||
LoadChar(ch);
|
||||
if (ch == '.') {
|
||||
/* Indeed the '..' token
|
||||
*/
|
||||
PushBack(ch);
|
||||
PushBack(ch);
|
||||
goto Sdec;
|
||||
}
|
||||
|
||||
/* a real constant */
|
||||
if (np < &buf[NUMSIZE]) {
|
||||
*np++ = '.';
|
||||
}
|
||||
|
||||
if (is_dig(ch)) {
|
||||
/* Fractional part
|
||||
*/
|
||||
do {
|
||||
if (np < &buf[NUMSIZE]) {
|
||||
*np++ = ch;
|
||||
}
|
||||
LoadChar(ch);
|
||||
} while (is_dig(ch));
|
||||
}
|
||||
|
||||
if (ch == 'E') {
|
||||
/* Scale factor
|
||||
*/
|
||||
if (np < &buf[NUMSIZE]) {
|
||||
*np++ = 'E';
|
||||
}
|
||||
LoadChar(ch);
|
||||
if (ch == '+' || ch == '-') {
|
||||
/* Signed scalefactor
|
||||
*/
|
||||
if (np < &buf[NUMSIZE]) {
|
||||
*np++ = ch;
|
||||
}
|
||||
LoadChar(ch);
|
||||
}
|
||||
if (is_dig(ch)) {
|
||||
do {
|
||||
if (np < &buf[NUMSIZE]) {
|
||||
*np++ = ch;
|
||||
}
|
||||
LoadChar(ch);
|
||||
} while (is_dig(ch));
|
||||
}
|
||||
else {
|
||||
lexerror("bad scale factor");
|
||||
}
|
||||
}
|
||||
|
||||
PushBack(ch);
|
||||
|
||||
if (np == &buf[NUMSIZE + 1]) {
|
||||
lexerror("floating constant too long");
|
||||
tk->TOK_REL = Salloc("0.0", 5);
|
||||
}
|
||||
else {
|
||||
tk->TOK_REL = Salloc(buf, np - buf) + 1;
|
||||
}
|
||||
return tk->tk_symb = REAL;
|
||||
|
||||
default:
|
||||
PushBack(ch);
|
||||
Sdec:
|
||||
*np++ = '\0';
|
||||
/* Type is an integer */
|
||||
tk->TOK_INT = str2long(&buf[1], 10);
|
||||
return tk->tk_symb = INTEGER;
|
||||
}
|
||||
/*NOTREACHED*/
|
||||
}
|
||||
|
||||
case STEOI:
|
||||
return tk->tk_symb = EOI;
|
||||
|
||||
case STCHAR:
|
||||
default:
|
||||
crash("bad character class %d", class(ch));
|
||||
}
|
||||
}
|
||||
|
||||
char *
|
||||
GetString(upto)
|
||||
{
|
||||
register int ch;
|
||||
int str_size;
|
||||
char *str = Malloc(str_size = 32);
|
||||
register int pos = 0;
|
||||
|
||||
LoadChar(ch);
|
||||
while (ch != upto) {
|
||||
if (class(ch) == STNL) {
|
||||
lexerror("newline in string");
|
||||
LineNumber++;
|
||||
break;
|
||||
}
|
||||
if (ch == EOI) {
|
||||
lexerror("end-of-file in string");
|
||||
break;
|
||||
}
|
||||
str[pos++] = ch;
|
||||
if (pos == str_size) {
|
||||
str = Srealloc(str, str_size += 8);
|
||||
}
|
||||
LoadChar(ch);
|
||||
}
|
||||
str[pos] = '\0';
|
||||
return str;
|
||||
}
|
||||
|
||||
SkipComment()
|
||||
{
|
||||
/* Skip Modula-2 like comment (* ... *).
|
||||
Note that comment may be nested.
|
||||
*/
|
||||
|
||||
register int ch;
|
||||
register int NestLevel = 0;
|
||||
|
||||
LoadChar(ch);
|
||||
for (;;) {
|
||||
if (class(ch) == STNL) {
|
||||
LineNumber++;
|
||||
}
|
||||
else
|
||||
if (ch == '(') {
|
||||
LoadChar(ch);
|
||||
if (ch == '*') {
|
||||
++NestLevel;
|
||||
}
|
||||
else {
|
||||
continue;
|
||||
}
|
||||
}
|
||||
else
|
||||
if (ch == '*') {
|
||||
LoadChar(ch);
|
||||
if (ch == ')') {
|
||||
if (NestLevel-- == 0) {
|
||||
return;
|
||||
}
|
||||
}
|
||||
else {
|
||||
continue;
|
||||
}
|
||||
}
|
||||
LoadChar(ch);
|
||||
}
|
||||
}
|
27
lang/m2/comp/LLlex.h
Normal file
27
lang/m2/comp/LLlex.h
Normal file
|
@ -0,0 +1,27 @@
|
|||
/* Token Descriptor Definition */
|
||||
|
||||
/* $Header$ */
|
||||
|
||||
struct token {
|
||||
int tk_symb; /* token itself */
|
||||
union {
|
||||
struct idf *tk_idf; /* IDENT */
|
||||
char *tk_str; /* STRING */
|
||||
struct { /* INTEGER */
|
||||
int tk_type; /* type */
|
||||
long tk_value; /* value */
|
||||
} tk_int;
|
||||
char *tk_real; /* REAL */
|
||||
} tk_data;
|
||||
};
|
||||
|
||||
#define TOK_IDF tk_data.tk_idf
|
||||
#define TOK_STR tk_data.tk_str
|
||||
#define TOK_ITP tk_data.tk_int.tk_type
|
||||
#define TOK_INT tk_data.tk_int.tk_value
|
||||
#define TOK_REL tk_data.tk_real
|
||||
|
||||
extern struct token dot, aside;
|
||||
|
||||
#define DOT dot.tk_symb
|
||||
#define ASIDE aside.tk_symb
|
69
lang/m2/comp/LLmessage.c
Normal file
69
lang/m2/comp/LLmessage.c
Normal file
|
@ -0,0 +1,69 @@
|
|||
#include <alloc.h>
|
||||
#include "f_info.h"
|
||||
#include "idf.h"
|
||||
#include "LLlex.h"
|
||||
#include "Lpars.h"
|
||||
|
||||
static char *RcsId = "$Header$";
|
||||
|
||||
extern char *symbol2str();
|
||||
int err_occurred = 0;
|
||||
|
||||
LLmessage(tk)
|
||||
int tk;
|
||||
{
|
||||
++err_occurred;
|
||||
if (tk) {
|
||||
error("%s missing", symbol2str(tk));
|
||||
insert_token(tk);
|
||||
}
|
||||
else
|
||||
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;
|
||||
{
|
||||
aside = dot;
|
||||
|
||||
dot.tk_symb = tk;
|
||||
|
||||
switch (tk) {
|
||||
/* The operands need some body */
|
||||
case IDENT:
|
||||
dot.TOK_IDF = gen_anon_idf();
|
||||
break;
|
||||
case STRING:
|
||||
dot.TOK_STR = Salloc("", 1);
|
||||
break;
|
||||
case INTEGER:
|
||||
/* dot.TOK_ITP = INT; */
|
||||
dot.TOK_INT = 1;
|
||||
break;
|
||||
case REAL:
|
||||
dot.TOK_REL = Salloc("0.0", 4);
|
||||
break;
|
||||
}
|
||||
}
|
78
lang/m2/comp/Makefile
Normal file
78
lang/m2/comp/Makefile
Normal file
|
@ -0,0 +1,78 @@
|
|||
# make modula-2 "compiler"
|
||||
# $Header$
|
||||
|
||||
HDIR = ../../em/h
|
||||
PKGDIR = ../../em/pkg
|
||||
LIBDIR = ../../em/lib
|
||||
INCLUDES = -I$(HDIR) -I$(PKGDIR) -I/user1/erikb/h
|
||||
LSRC = tokenfile.g program.g declar.g expression.g statement.g
|
||||
CC = cc
|
||||
GEN = LLgen
|
||||
GENOPTIONS =
|
||||
CFLAGS = -DDEBUG -O $(INCLUDES)
|
||||
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
|
||||
OBJ = $(COBJ) $(LOBJ) Lpars.o
|
||||
GENFILES= tokenfile.c \
|
||||
program.c declar.c expression.c statement.c \
|
||||
tokenfile.g symbol2str.c char.c Lpars.c Lpars.h
|
||||
|
||||
all:
|
||||
make LLfiles
|
||||
make main
|
||||
|
||||
LLfiles: $(LSRC)
|
||||
$(GEN) $(GENOPTIONS) $(LSRC)
|
||||
@touch LLfiles
|
||||
|
||||
main: $(OBJ) Makefile
|
||||
$(CC) $(LFLAGS) $(OBJ) $(LIBDIR)/libcomp.a /user1/erikb/em/lib/libstr.a /user1/erikb/lib/libsystem.a -o main
|
||||
size main
|
||||
|
||||
clean:
|
||||
rm -f $(OBJ) $(GENFILES) LLfiles
|
||||
|
||||
tokenfile.g: tokenname.c make.tokfile
|
||||
make.tokfile <tokenname.c >tokenfile.g
|
||||
|
||||
symbol2str.c: tokenname.c make.tokcase
|
||||
make.tokcase <tokenname.c >symbol2str.c
|
||||
|
||||
idlist.h: idlist.H make.allocd
|
||||
|
||||
char.c: char.tab tab
|
||||
./tab -fchar.tab >char.c
|
||||
|
||||
tab:
|
||||
$(CC) tab.c -o tab
|
||||
|
||||
depend:
|
||||
sed '/^#AUTOAUTO/,$$d' Makefile > Makefile.new
|
||||
echo '#AUTOAUTOAUTOAUTOAUTOAUTOAUTOAUTO' >> Makefile.new
|
||||
/user1/erikb/bin/mkdep `sources $(OBJ)` |\
|
||||
sed 's/\.c:/\.o:/' >> Makefile.new
|
||||
mv Makefile Makefile.old
|
||||
mv Makefile.new Makefile
|
||||
|
||||
.SUFFIXES: .H .h .C
|
||||
.H.h .C.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
|
||||
char.o: class.h
|
||||
error.o: LLlex.h f_info.h
|
||||
main.o: LLlex.h Lpars.h f_info.h idf.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
|
||||
tokenfile.o: Lpars.h
|
||||
program.o: Lpars.h idf.h idlist.h
|
||||
declar.o: LLlex.h Lpars.h idf.h idlist.h
|
||||
expression.o: Lpars.h
|
||||
statement.o: Lpars.h
|
||||
Lpars.o: Lpars.h
|
54
lang/m2/comp/char.tab
Normal file
54
lang/m2/comp/char.tab
Normal file
|
@ -0,0 +1,54 @@
|
|||
% character tables for mod2 compiler
|
||||
% $Header$
|
||||
%S129
|
||||
%F %s,
|
||||
%
|
||||
% CHARACTER CLASSES
|
||||
%
|
||||
%C
|
||||
STGARB:\000-\200
|
||||
STSKIP: \r\t
|
||||
STNL:\012\013\014
|
||||
STSIMP:#&()*+,-/;=[]^{|}~
|
||||
STCOMP:.:<>
|
||||
STIDF:a-zA-Z
|
||||
STSTR:"'
|
||||
STNUM:0-9
|
||||
STEOI:\200
|
||||
%T#include "class.h"
|
||||
%Tchar tkclass[] = {
|
||||
%p
|
||||
%T};
|
||||
%
|
||||
% INIDF
|
||||
%
|
||||
%C
|
||||
1:a-zA-Z_0-9
|
||||
%Tchar inidf[] = {
|
||||
%F %s,
|
||||
%p
|
||||
%T};
|
||||
%
|
||||
% ISDIG
|
||||
%
|
||||
%C
|
||||
1:0-9
|
||||
%Tchar isdig[] = {
|
||||
%p
|
||||
%T};
|
||||
%
|
||||
% ISHEX
|
||||
%
|
||||
%C
|
||||
1:a-fA-F
|
||||
%Tchar ishex[] = {
|
||||
%p
|
||||
%T};
|
||||
%
|
||||
% ISOCT
|
||||
%
|
||||
%C
|
||||
1:0-7
|
||||
%Tchar isoct[] = {
|
||||
%p
|
||||
%T};
|
38
lang/m2/comp/class.h
Normal file
38
lang/m2/comp/class.h
Normal file
|
@ -0,0 +1,38 @@
|
|||
/* U S E O F C H A R A C T E R C L A S S E S */
|
||||
|
||||
/* $Header$ */
|
||||
|
||||
/* As a starter, chars are divided into classes, according to which
|
||||
token they can be the start of.
|
||||
At present such a class number is supposed to fit in 4 bits.
|
||||
*/
|
||||
|
||||
#define class(ch) (tkclass[ch])
|
||||
|
||||
/* Being the start of a token is, fortunately, a mutual exclusive
|
||||
property, so, as there are less than 16 classes they can be
|
||||
packed in 4 bits.
|
||||
*/
|
||||
|
||||
#define STSKIP 0 /* spaces and so on: skipped characters */
|
||||
#define STNL 1 /* newline character(s): update linenumber etc. */
|
||||
#define STGARB 2 /* garbage ascii character: not allowed */
|
||||
#define STSIMP 3 /* this character can occur as token */
|
||||
#define STCOMP 4 /* this one can start a compound token */
|
||||
#define STIDF 5 /* being the initial character of an identifier */
|
||||
#define STCHAR 6 /* the starter of a character constant */
|
||||
#define STSTR 7 /* the starter of a string */
|
||||
#define STNUM 8 /* the starter of a numeric constant */
|
||||
#define STEOI 9 /* End-Of-Information mark */
|
||||
|
||||
/* But occurring inside a token is not, so we need 1 bit for each
|
||||
class. This is implemented as a collection of tables to speed up
|
||||
the decision whether a character has a special meaning.
|
||||
*/
|
||||
#define in_idf(ch) (inidf[ch])
|
||||
#define is_oct(ch) (isoct[ch])
|
||||
#define is_dig(ch) (isdig[ch])
|
||||
#define is_hex(ch) (ishex[ch])
|
||||
|
||||
extern char tkclass[];
|
||||
extern char inidf[], isoct[], isdig[], ishex[];
|
181
lang/m2/comp/declar.g
Normal file
181
lang/m2/comp/declar.g
Normal file
|
@ -0,0 +1,181 @@
|
|||
{
|
||||
#include "idf.h"
|
||||
#include "idlist.h"
|
||||
#include "LLlex.h"
|
||||
|
||||
static char *RcsId = "$Header$";
|
||||
}
|
||||
|
||||
ProcedureDeclaration:
|
||||
ProcedureHeading ';' block IDENT
|
||||
;
|
||||
|
||||
ProcedureHeading:
|
||||
PROCEDURE IDENT FormalParameters?
|
||||
;
|
||||
|
||||
block:
|
||||
declaration* [ BEGIN StatementSequence ]? END
|
||||
;
|
||||
|
||||
declaration:
|
||||
CONST [ ConstantDeclaration ';' ]*
|
||||
|
|
||||
TYPE [ TypeDeclaration ';' ]*
|
||||
|
|
||||
VAR [ VariableDeclaration ';' ]*
|
||||
|
|
||||
ProcedureDeclaration ';'
|
||||
|
|
||||
ModuleDeclaration ';'
|
||||
;
|
||||
|
||||
FormalParameters:
|
||||
'(' [ FPSection [ ';' FPSection ]* ]? ')'
|
||||
[ ':' qualident ]?
|
||||
;
|
||||
|
||||
FPSection
|
||||
{
|
||||
struct id_list *FPList;
|
||||
} :
|
||||
VAR? IdentList(&FPList) ':' FormalType
|
||||
;
|
||||
|
||||
FormalType:
|
||||
[ ARRAY OF ]? qualident
|
||||
;
|
||||
|
||||
TypeDeclaration:
|
||||
IDENT '=' type
|
||||
;
|
||||
|
||||
type:
|
||||
SimpleType
|
||||
|
|
||||
ArrayType
|
||||
|
|
||||
RecordType
|
||||
|
|
||||
SetType
|
||||
|
|
||||
PointerType
|
||||
|
|
||||
ProcedureType
|
||||
;
|
||||
|
||||
SimpleType:
|
||||
qualident
|
||||
[
|
||||
|
||||
|
|
||||
SubrangeType
|
||||
/*
|
||||
* The subrange type is given a base type by the
|
||||
* qualident (this is new modula-2).
|
||||
*/
|
||||
]
|
||||
|
|
||||
enumeration
|
||||
|
|
||||
SubrangeType
|
||||
;
|
||||
|
||||
enumeration
|
||||
{
|
||||
struct id_list *EnumList;
|
||||
} :
|
||||
'(' IdentList(&EnumList) ')'
|
||||
;
|
||||
|
||||
IdentList(struct id_list **p;)
|
||||
{
|
||||
register struct id_list *q = new_id_list();
|
||||
} :
|
||||
IDENT { q->id_ptr = dot.TOK_IDF; }
|
||||
[
|
||||
',' IDENT { q->next = new_id_list();
|
||||
q = q->next;
|
||||
q->id_ptr = dot.TOK_IDF;
|
||||
}
|
||||
]*
|
||||
{ q->next = 0;
|
||||
*p = q;
|
||||
}
|
||||
;
|
||||
|
||||
SubrangeType:
|
||||
/*
|
||||
This is not exactly the rule in the new report, but see
|
||||
the rule for "SimpleType".
|
||||
*/
|
||||
'[' ConstExpression UPTO ConstExpression ']'
|
||||
;
|
||||
|
||||
ArrayType:
|
||||
ARRAY SimpleType [ ',' SimpleType ]* OF type
|
||||
;
|
||||
|
||||
RecordType:
|
||||
RECORD FieldListSequence END
|
||||
;
|
||||
|
||||
FieldListSequence:
|
||||
FieldList [ ';' FieldList ]*
|
||||
;
|
||||
|
||||
FieldList
|
||||
{
|
||||
struct id_list *FldList;
|
||||
} :
|
||||
[
|
||||
IdentList(&FldList) ':' type
|
||||
|
|
||||
CASE IDENT? /* Changed rule in new modula-2 */
|
||||
':' qualident
|
||||
OF variant [ '|' variant ]*
|
||||
[ ELSE FieldListSequence ]?
|
||||
END
|
||||
]?
|
||||
;
|
||||
|
||||
variant:
|
||||
[ CaseLabelList ':' FieldListSequence ]?
|
||||
/* Changed rule in new modula-2 */
|
||||
;
|
||||
|
||||
CaseLabelList:
|
||||
CaseLabels [ ',' CaseLabels ]*
|
||||
;
|
||||
|
||||
CaseLabels:
|
||||
ConstExpression [ UPTO ConstExpression ]?
|
||||
;
|
||||
|
||||
SetType:
|
||||
SET OF SimpleType
|
||||
;
|
||||
|
||||
PointerType:
|
||||
POINTER TO type
|
||||
;
|
||||
|
||||
ProcedureType:
|
||||
PROCEDURE FormalTypeList?
|
||||
;
|
||||
|
||||
FormalTypeList:
|
||||
'(' [ VAR? FormalType [ ',' VAR? FormalType ]* ]? ')'
|
||||
[ ':' qualident ]?
|
||||
;
|
||||
|
||||
ConstantDeclaration:
|
||||
IDENT '=' ConstExpression
|
||||
;
|
||||
|
||||
VariableDeclaration
|
||||
{
|
||||
struct id_list *VarList;
|
||||
} :
|
||||
IdentList(&VarList) ':' type
|
||||
;
|
170
lang/m2/comp/error.c
Normal file
170
lang/m2/comp/error.c
Normal file
|
@ -0,0 +1,170 @@
|
|||
/* 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>
|
||||
#include "input.h"
|
||||
#include "f_info.h"
|
||||
#include "LLlex.h"
|
||||
|
||||
static char *RcsId = "$Header$";
|
||||
|
||||
#define ERROUT stderr
|
||||
|
||||
#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
|
||||
|
||||
int err_occurred;
|
||||
/*
|
||||
extern int ofd; /* compact.c * /
|
||||
#define compiling (ofd >= 0)
|
||||
*/
|
||||
|
||||
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.
|
||||
*/
|
||||
|
||||
/*VARARGS1*/
|
||||
error(fmt, args)
|
||||
char *fmt;
|
||||
{
|
||||
/*
|
||||
if (compiling)
|
||||
C_ms_err();
|
||||
*/
|
||||
++err_occurred;
|
||||
_error(ERROR, fmt, &args);
|
||||
}
|
||||
|
||||
#ifdef DEBUG
|
||||
debug(fmt, args)
|
||||
char *fmt;
|
||||
{
|
||||
if (options['D'])
|
||||
_error(VDEBUG, fmt, &args);
|
||||
}
|
||||
#endif DEBUG
|
||||
|
||||
/*VARARGS1*/
|
||||
lexerror(fmt, args)
|
||||
char *fmt;
|
||||
{
|
||||
/*
|
||||
if (compiling)
|
||||
C_ms_err();
|
||||
*/
|
||||
++err_occurred;
|
||||
_error(LEXERROR, fmt, &args);
|
||||
}
|
||||
|
||||
/*VARARGS1*/
|
||||
lexwarning(fmt, args) char *fmt; {
|
||||
if (options['w']) return;
|
||||
_error(LEXWARNING, fmt, &args);
|
||||
}
|
||||
|
||||
/*VARARGS1*/
|
||||
crash(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) */
|
||||
}
|
||||
|
||||
/*VARARGS1*/
|
||||
fatal(fmt, args)
|
||||
char *fmt;
|
||||
int args;
|
||||
{
|
||||
/*
|
||||
if (compiling)
|
||||
C_ms_err();
|
||||
*/
|
||||
_error(FATAL, fmt, &args);
|
||||
exit(-1);
|
||||
}
|
||||
|
||||
/*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)
|
||||
int class;
|
||||
char *fmt;
|
||||
int argv[];
|
||||
{
|
||||
|
||||
switch (class) {
|
||||
|
||||
case ERROR:
|
||||
case LEXERROR:
|
||||
fprintf(ERROUT, "%s, line %ld: ", FileName, LineNumber);
|
||||
break;
|
||||
case WARNING:
|
||||
case LEXWARNING:
|
||||
fprintf(ERROUT, "%s, line %ld: (warning) ",
|
||||
FileName, LineNumber);
|
||||
break;
|
||||
case CRASH:
|
||||
fprintf(ERROUT, "CRASH\007 %s, line %ld: \n",
|
||||
FileName, LineNumber);
|
||||
break;
|
||||
case FATAL:
|
||||
fprintf(ERROUT, "%s, line %ld: fatal error -- ",
|
||||
FileName, LineNumber);
|
||||
break;
|
||||
case NONFATAL:
|
||||
fprintf(ERROUT, "warning: "); /* no line number ??? */
|
||||
break;
|
||||
#ifdef DEBUG
|
||||
case VDEBUG:
|
||||
fprintf(ERROUT, "-D ");
|
||||
break;
|
||||
#endif DEBUG
|
||||
}
|
||||
_doprnt(fmt, argv, ERROUT);
|
||||
fprintf(ERROUT, "\n");
|
||||
}
|
97
lang/m2/comp/expression.g
Normal file
97
lang/m2/comp/expression.g
Normal file
|
@ -0,0 +1,97 @@
|
|||
{
|
||||
static char *RcsId = "$Header$";
|
||||
}
|
||||
|
||||
number:
|
||||
INTEGER
|
||||
|
|
||||
REAL
|
||||
;
|
||||
|
||||
qualident:
|
||||
IDENT selector*
|
||||
;
|
||||
|
||||
selector:
|
||||
'.' /* field */ IDENT
|
||||
;
|
||||
|
||||
ExpList:
|
||||
expression [ ',' expression ]*
|
||||
;
|
||||
|
||||
ConstExpression:
|
||||
expression
|
||||
/*
|
||||
* Changed rule in new Modula-2.
|
||||
* Check that the expression is a constant expression and evaluate!
|
||||
*/
|
||||
;
|
||||
|
||||
expression:
|
||||
SimpleExpression [ relation SimpleExpression ]?
|
||||
;
|
||||
|
||||
relation:
|
||||
'=' | '#' | UNEQUAL | '<' | LESSEQUAL | '>' | GREATEREQUAL | IN
|
||||
;
|
||||
|
||||
SimpleExpression:
|
||||
[ '+' | '-' ]? term [ AddOperator term ]*
|
||||
;
|
||||
|
||||
AddOperator:
|
||||
'+' | '-' | OR
|
||||
;
|
||||
|
||||
term:
|
||||
factor [ MulOperator factor ]*
|
||||
;
|
||||
|
||||
MulOperator:
|
||||
'*' | '/' | DIV | MOD | AND | '&'
|
||||
;
|
||||
|
||||
factor:
|
||||
qualident
|
||||
[
|
||||
designator_tail? ActualParameters?
|
||||
|
|
||||
bare_set
|
||||
]
|
||||
|
|
||||
bare_set
|
||||
| %default
|
||||
number
|
||||
|
|
||||
STRING
|
||||
|
|
||||
'(' expression ')'
|
||||
|
|
||||
NOT factor
|
||||
;
|
||||
|
||||
bare_set:
|
||||
'{' [ element [ ',' element ]* ]? '}'
|
||||
;
|
||||
|
||||
ActualParameters:
|
||||
'(' ExpList? ')'
|
||||
;
|
||||
|
||||
element:
|
||||
expression [ UPTO expression ]?
|
||||
;
|
||||
|
||||
designator:
|
||||
qualident designator_tail?
|
||||
;
|
||||
|
||||
designator_tail:
|
||||
visible_designator_tail
|
||||
[ selector | visible_designator_tail ]*
|
||||
;
|
||||
|
||||
visible_designator_tail:
|
||||
'[' ExpList ']' | '^'
|
||||
;
|
11
lang/m2/comp/f_info.h
Normal file
11
lang/m2/comp/f_info.h
Normal file
|
@ -0,0 +1,11 @@
|
|||
/* $Header$ */
|
||||
|
||||
struct f_info {
|
||||
unsigned int f_lineno;
|
||||
char *f_filename;
|
||||
char *f_workingdir;
|
||||
};
|
||||
|
||||
extern struct f_info file_info;
|
||||
#define LineNumber file_info.f_lineno
|
||||
#define FileName file_info.f_filename
|
4
lang/m2/comp/idf.c
Normal file
4
lang/m2/comp/idf.c
Normal file
|
@ -0,0 +1,4 @@
|
|||
/* $Header$ */
|
||||
|
||||
#include "idf.h"
|
||||
#include <idf_pkg.body>
|
5
lang/m2/comp/idf.h
Normal file
5
lang/m2/comp/idf.h
Normal file
|
@ -0,0 +1,5 @@
|
|||
/* $Header$ */
|
||||
|
||||
#define IDF_TYPE int
|
||||
#define id_reserved id_user
|
||||
#include <idf_pkg.spec>
|
12
lang/m2/comp/idlist.H
Normal file
12
lang/m2/comp/idlist.H
Normal file
|
@ -0,0 +1,12 @@
|
|||
/* $Header$ */
|
||||
|
||||
#include <alloc.h>
|
||||
|
||||
/* Structure to link idf structures together
|
||||
*/
|
||||
struct id_list {
|
||||
struct id_list *next;
|
||||
struct idf *id_ptr;
|
||||
};
|
||||
|
||||
/* ALLOCDEF "id_list" */
|
20
lang/m2/comp/idlist.c
Normal file
20
lang/m2/comp/idlist.c
Normal file
|
@ -0,0 +1,20 @@
|
|||
static char *RcsId = "$Header$";
|
||||
|
||||
#include "idf.h"
|
||||
#include "idlist.h"
|
||||
|
||||
struct id_list *h_id_list; /* Header of free list */
|
||||
|
||||
/* 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);
|
||||
}
|
||||
}
|
6
lang/m2/comp/input.c
Normal file
6
lang/m2/comp/input.c
Normal file
|
@ -0,0 +1,6 @@
|
|||
/* $Header$ */
|
||||
|
||||
#include "f_info.h"
|
||||
struct f_info file_info;
|
||||
#include "input.h"
|
||||
#include <inp_pkg.body>
|
7
lang/m2/comp/input.h
Normal file
7
lang/m2/comp/input.h
Normal file
|
@ -0,0 +1,7 @@
|
|||
/* $Header$ */
|
||||
|
||||
#define INP_NPUSHBACK 2
|
||||
#define INP_TYPE struct f_info
|
||||
#define INP_VAR file_info
|
||||
#define INP_READ_IN_ONE
|
||||
#include <inp_pkg.spec>
|
121
lang/m2/comp/main.c
Normal file
121
lang/m2/comp/main.c
Normal file
|
@ -0,0 +1,121 @@
|
|||
/* 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"
|
||||
|
||||
static char *RcsId = "$Header:";
|
||||
|
||||
char options[128];
|
||||
char *ProgName;
|
||||
extern int err_occurred;
|
||||
|
||||
main(argc, argv)
|
||||
char *argv[];
|
||||
{
|
||||
register Nargc = 1;
|
||||
register char **Nargv = &argv[0];
|
||||
|
||||
ProgName = *argv++;
|
||||
|
||||
# ifdef DEBUG
|
||||
setbuf(stdout, (char *) 0);
|
||||
# endif
|
||||
while (--argc > 0) {
|
||||
if (**argv == '-')
|
||||
Option(*argv++);
|
||||
else
|
||||
Nargv[Nargc++] = *argv++;
|
||||
}
|
||||
Nargv[Nargc] = 0; /* terminate the arg vector */
|
||||
if (Nargc != 2) {
|
||||
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
|
||||
return !Compile(Nargv[1]);
|
||||
}
|
||||
|
||||
Compile(src)
|
||||
char *src;
|
||||
{
|
||||
extern struct tokenname tkidf[];
|
||||
|
||||
#ifdef DEBUG
|
||||
printf("%s\n", src);
|
||||
#endif DEBUG
|
||||
if (! InsertFile(src, (char **) 0)) {
|
||||
fprintf(stderr,"%s: cannot open %s\n", ProgName, src);
|
||||
return 0;
|
||||
}
|
||||
LineNumber = 1;
|
||||
FileName = src;
|
||||
init_idf();
|
||||
reserve(tkidf);
|
||||
#ifdef DEBUG
|
||||
if (options['L'])
|
||||
LexScan();
|
||||
else if (options['T'])
|
||||
TimeScan();
|
||||
else
|
||||
#endif DEBUG
|
||||
CompUnit();
|
||||
#ifdef DEBUG
|
||||
if (options['h']) hash_stat();
|
||||
#endif DEBUG
|
||||
if (err_occurred) return 0;
|
||||
return 1;
|
||||
}
|
||||
|
||||
#ifdef DEBUG
|
||||
LexScan()
|
||||
{
|
||||
register int symb;
|
||||
|
||||
while ((symb = LLlex()) != EOF) {
|
||||
printf(">>> %s ", symbol2str(symb));
|
||||
switch(symb) {
|
||||
|
||||
case IDENT:
|
||||
printf("%s\n", dot.TOK_IDF->id_text);
|
||||
break;
|
||||
|
||||
case INTEGER:
|
||||
printf("%ld\n", dot.TOK_INT);
|
||||
break;
|
||||
|
||||
case REAL:
|
||||
printf("%s\n", dot.TOK_REL);
|
||||
break;
|
||||
|
||||
case STRING:
|
||||
printf("\"%s\"\n", dot.TOK_STR);
|
||||
break;
|
||||
|
||||
default:
|
||||
putchar('\n');
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
TimeScan() {
|
||||
while (LLlex() != EOF) /* nothing */;
|
||||
}
|
||||
#endif
|
||||
|
||||
Option(str)
|
||||
char *str;
|
||||
{
|
||||
#ifdef DEBUG
|
||||
debug("option %c", str[1]);
|
||||
#endif DEBUG
|
||||
options[str[1]]++; /* switch option on */
|
||||
}
|
17
lang/m2/comp/make.allocd
Executable file
17
lang/m2/comp/make.allocd
Executable file
|
@ -0,0 +1,17 @@
|
|||
sed -e '
|
||||
s:^.*[ ]ALLOCDEF[ ].*"\(.*\)".*$:\
|
||||
/* allocation definitions of struct \1 */\
|
||||
extern char *st_alloc();\
|
||||
extern struct \1 *h_\1;\
|
||||
#define new_\1() ((struct \1 *) \\\
|
||||
st_alloc((char **)\&h_\1, sizeof(struct \1)))\
|
||||
#define free_\1(p) st_free(p, h_\1, sizeof(struct \1))\
|
||||
:' -e '
|
||||
s:^.*[ ]STATICALLOCDEF[ ].*"\(.*\)".*$:\
|
||||
/* allocation definitions of struct \1 */\
|
||||
extern char *st_alloc();\
|
||||
static struct \1 *h_\1;\
|
||||
#define new_\1() ((struct \1 *) \\\
|
||||
st_alloc((char **)\&h_\1, sizeof(struct \1)))\
|
||||
#define free_\1(p) st_free(p, h_\1, sizeof(struct \1))\
|
||||
:'
|
34
lang/m2/comp/make.tokcase
Executable file
34
lang/m2/comp/make.tokcase
Executable file
|
@ -0,0 +1,34 @@
|
|||
cat <<'--EOT--'
|
||||
#include "Lpars.h"
|
||||
|
||||
char *
|
||||
symbol2str(tok)
|
||||
int tok;
|
||||
{
|
||||
static char buf[2] = { '\0', '\0' };
|
||||
|
||||
if (040 <= tok && tok < 0177) {
|
||||
buf[0] = tok;
|
||||
buf[1] = '\0';
|
||||
return buf;
|
||||
}
|
||||
switch (tok) {
|
||||
--EOT--
|
||||
sed '
|
||||
/{[A-Z]/!d
|
||||
s/.*{\(.*\),.*\(".*"\).*$/ case \1 :\
|
||||
return \2;/
|
||||
'
|
||||
cat <<'--EOT--'
|
||||
case '\n':
|
||||
case '\f':
|
||||
case '\v':
|
||||
case '\r':
|
||||
case '\t':
|
||||
buf[0] = tok;
|
||||
return buf;
|
||||
default:
|
||||
return "bad token";
|
||||
}
|
||||
}
|
||||
--EOT--
|
6
lang/m2/comp/make.tokfile
Executable file
6
lang/m2/comp/make.tokfile
Executable file
|
@ -0,0 +1,6 @@
|
|||
sed '
|
||||
/{[A-Z]/!d
|
||||
s/.*{//
|
||||
s/,.*//
|
||||
s/.*/%token &;/
|
||||
'
|
4
lang/m2/comp/param.h
Normal file
4
lang/m2/comp/param.h
Normal file
|
@ -0,0 +1,4 @@
|
|||
/* $Header$ */
|
||||
|
||||
#define IDFSIZE 256
|
||||
#define NUMSIZE 256
|
116
lang/m2/comp/program.g
Normal file
116
lang/m2/comp/program.g
Normal file
|
@ -0,0 +1,116 @@
|
|||
/*
|
||||
Program: Modula-2 grammar in LL(1) form
|
||||
Version: Mon Feb 24 14:29:39 MET 1986
|
||||
*/
|
||||
|
||||
/*
|
||||
The grammar as given by Wirth is already almost LL(1); the
|
||||
main problem is that the full form of a qualified designator
|
||||
may be:
|
||||
[ module_ident '.' ]* IDENT [ '.' field_ident ]*
|
||||
which is quite confusing to an LL(1) parser. Rather than
|
||||
resorting to context-sensitive techniques, I have decided
|
||||
to render this as:
|
||||
IDENT [ '.' IDENT ]*
|
||||
on the grounds that it is quite natural to consider the first
|
||||
IDENT to be the name of the object and regard the others as
|
||||
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
|
||||
;
|
||||
|
||||
priority:
|
||||
'[' ConstExpression ']'
|
||||
;
|
||||
|
||||
export
|
||||
{
|
||||
struct id_list *ExportList;
|
||||
} :
|
||||
EXPORT QUALIFIED? IdentList(&ExportList) ';'
|
||||
;
|
||||
|
||||
import
|
||||
{
|
||||
struct id_list *ImportList;
|
||||
} :
|
||||
[ FROM
|
||||
IDENT
|
||||
]?
|
||||
IMPORT IdentList(&ImportList) ';'
|
||||
/*
|
||||
When parsing a global module, this is the place where we must
|
||||
read already compiled definition modules.
|
||||
If the FROM clause is present, the identifier in it is a module
|
||||
name, otherwise the names in the import list are module names.
|
||||
*/
|
||||
;
|
||||
|
||||
DefinitionModule:
|
||||
DEFINITION
|
||||
{
|
||||
#ifdef DEBUG
|
||||
debug("Definition module");
|
||||
#endif DEBUG
|
||||
}
|
||||
MODULE IDENT ';' import*
|
||||
/* export?
|
||||
|
||||
New Modula-2 does not have export lists in definition modules.
|
||||
*/
|
||||
definition* END IDENT '.'
|
||||
;
|
||||
|
||||
definition:
|
||||
CONST [ ConstantDeclaration ';' ]*
|
||||
|
|
||||
TYPE
|
||||
[ IDENT
|
||||
[ '=' type
|
||||
| /* empty */
|
||||
/*
|
||||
Here, the exported type has a hidden implementation.
|
||||
The export is said to be opaque.
|
||||
It is restricted to pointer types.
|
||||
*/
|
||||
]
|
||||
';'
|
||||
]*
|
||||
|
|
||||
VAR [ VariableDeclaration ';' ]*
|
||||
|
|
||||
ProcedureHeading ';'
|
||||
;
|
||||
|
||||
ProgramModule:
|
||||
MODULE
|
||||
{
|
||||
#ifdef DEBUG
|
||||
debug("Program module");
|
||||
#endif DEBUG
|
||||
}
|
||||
IDENT priority? ';' import* block IDENT '.'
|
||||
;
|
||||
|
||||
Module:
|
||||
DefinitionModule
|
||||
|
|
||||
IMPLEMENTATION? ProgramModule
|
||||
;
|
||||
|
||||
CompilationUnit:
|
||||
Module
|
||||
;
|
98
lang/m2/comp/statement.g
Normal file
98
lang/m2/comp/statement.g
Normal file
|
@ -0,0 +1,98 @@
|
|||
{
|
||||
static char *RcsId = "$Header$";
|
||||
}
|
||||
|
||||
statement:
|
||||
[
|
||||
/*
|
||||
* This part is not in the reference grammar. The reference grammar
|
||||
* states : assignment | ProcedureCall | ...
|
||||
* but this gives LL(1) conflicts
|
||||
*/
|
||||
designator
|
||||
[
|
||||
ActualParameters?
|
||||
|
|
||||
BECOMES expression
|
||||
]
|
||||
/*
|
||||
* end of changed part
|
||||
*/
|
||||
|
|
||||
IfStatement
|
||||
|
|
||||
CaseStatement
|
||||
|
|
||||
WhileStatement
|
||||
|
|
||||
RepeatStatement
|
||||
|
|
||||
LoopStatement
|
||||
|
|
||||
ForStatement
|
||||
|
|
||||
WithStatement
|
||||
|
|
||||
EXIT
|
||||
|
|
||||
RETURN expression?
|
||||
]?
|
||||
;
|
||||
|
||||
/*
|
||||
* The next two rules in-line in "Statement", because of an LL(1) conflict
|
||||
|
||||
assignment:
|
||||
designator BECOMES expression
|
||||
;
|
||||
|
||||
ProcedureCall:
|
||||
designator ActualParameters?
|
||||
;
|
||||
*/
|
||||
|
||||
StatementSequence:
|
||||
statement [ ';' statement ]*
|
||||
;
|
||||
|
||||
IfStatement:
|
||||
IF expression THEN StatementSequence
|
||||
[ ELSIF expression THEN StatementSequence ]*
|
||||
[ ELSE StatementSequence ]?
|
||||
END
|
||||
;
|
||||
|
||||
CaseStatement:
|
||||
CASE expression OF case [ '|' case ]*
|
||||
[ ELSE StatementSequence ]?
|
||||
END
|
||||
;
|
||||
|
||||
case:
|
||||
[ CaseLabelList ':' StatementSequence ]?
|
||||
/* This rule is changed in new modula-2 */
|
||||
;
|
||||
|
||||
WhileStatement:
|
||||
WHILE expression DO StatementSequence END
|
||||
;
|
||||
|
||||
RepeatStatement:
|
||||
REPEAT StatementSequence UNTIL expression
|
||||
;
|
||||
|
||||
ForStatement:
|
||||
FOR IDENT
|
||||
BECOMES expression
|
||||
TO expression
|
||||
[ BY ConstExpression ]?
|
||||
DO StatementSequence END
|
||||
;
|
||||
|
||||
LoopStatement:
|
||||
LOOP StatementSequence END
|
||||
;
|
||||
|
||||
WithStatement:
|
||||
WITH designator DO StatementSequence END
|
||||
;
|
295
lang/m2/comp/tab.c
Normal file
295
lang/m2/comp/tab.c
Normal file
|
@ -0,0 +1,295 @@
|
|||
/* @cc tab.c -o $INSTALLDIR/tab@
|
||||
tab - table generator
|
||||
|
||||
Author: Erik Baalbergen (..tjalk!erikb)
|
||||
*/
|
||||
|
||||
#include <stdio.h>
|
||||
|
||||
static char *RcsId = "$Header$";
|
||||
|
||||
#define MAXTAB 10000
|
||||
#define MAXBUF 10000
|
||||
#define COMCOM '-'
|
||||
#define FILECOM '%'
|
||||
|
||||
int InputForm = 'c';
|
||||
char OutputForm[MAXBUF] = "%s,\n";
|
||||
int TabSize = 257;
|
||||
char *Table[MAXTAB];
|
||||
char *Name;
|
||||
char *ProgCall;
|
||||
|
||||
main(argc, argv)
|
||||
char *argv[];
|
||||
{
|
||||
ProgCall = *argv++;
|
||||
argc--;
|
||||
while (argc-- > 0) {
|
||||
if (**argv == COMCOM) {
|
||||
option(*argv++);
|
||||
}
|
||||
else {
|
||||
process(*argv++, InputForm);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
char *
|
||||
Salloc(s)
|
||||
char *s;
|
||||
{
|
||||
char *malloc();
|
||||
char *ns = malloc(strlen(s) + 1);
|
||||
|
||||
if (ns) {
|
||||
strcpy(ns, s);
|
||||
}
|
||||
return ns;
|
||||
}
|
||||
|
||||
option(str)
|
||||
char *str;
|
||||
{
|
||||
/* note that *str indicates the source of the option:
|
||||
either COMCOM (from command line) or FILECOM (from a file).
|
||||
*/
|
||||
switch (*++str) {
|
||||
|
||||
case ' ': /* command */
|
||||
case '\t':
|
||||
case '\0':
|
||||
break;
|
||||
case 'I':
|
||||
InputForm = *++str;
|
||||
break;
|
||||
case 'f':
|
||||
if (*++str == '\0') {
|
||||
fprintf(stderr, "%s: -f: name expected\n", ProgCall);
|
||||
exit(1);
|
||||
}
|
||||
DoFile(str);
|
||||
break;
|
||||
case 'F':
|
||||
sprintf(OutputForm, "%s\n", ++str);
|
||||
break;
|
||||
case 'T':
|
||||
printf("%s\n", ++str);
|
||||
break;
|
||||
case 'p':
|
||||
PrintTable();
|
||||
break;
|
||||
case 'C':
|
||||
ClearTable();
|
||||
break;
|
||||
case 'S':
|
||||
{
|
||||
register i = stoi(++str);
|
||||
|
||||
if (i <= 0 || i > MAXTAB) {
|
||||
fprintf(stderr, "%s: size would exceed maximum\n",
|
||||
ProgCall);
|
||||
}
|
||||
else {
|
||||
TabSize = i;
|
||||
}
|
||||
break;
|
||||
}
|
||||
default:
|
||||
fprintf(stderr, "%s: bad option -%s\n", ProgCall, str);
|
||||
}
|
||||
}
|
||||
|
||||
ClearTable()
|
||||
{
|
||||
register i;
|
||||
|
||||
for (i = 0; i < MAXTAB; i++) {
|
||||
Table[i] = 0;
|
||||
}
|
||||
}
|
||||
|
||||
PrintTable()
|
||||
{
|
||||
register i;
|
||||
|
||||
for (i = 0; i < TabSize; i++) {
|
||||
if (Table[i]) {
|
||||
printf(OutputForm, Table[i]);
|
||||
}
|
||||
else {
|
||||
printf(OutputForm, "0");
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
process(str, format)
|
||||
char *str;
|
||||
{
|
||||
char *cstr = str;
|
||||
char *Name = cstr; /* overwrite original string! */
|
||||
|
||||
/* strip of the entry name
|
||||
*/
|
||||
while (*str && *str != ':') {
|
||||
if (*str == '\\') {
|
||||
++str;
|
||||
}
|
||||
*cstr++ = *str++;
|
||||
}
|
||||
|
||||
if (*str != ':') {
|
||||
fprintf(stderr, "%s: bad specification: \"%s\", ignored\n",
|
||||
ProgCall, Name);
|
||||
return 0;
|
||||
}
|
||||
*cstr = '\0';
|
||||
str++;
|
||||
|
||||
switch (format) {
|
||||
|
||||
case 'c':
|
||||
return c_proc(str, Name);
|
||||
default:
|
||||
fprintf(stderr, "%s: bad input format\n", ProgCall);
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
c_proc(str, Name)
|
||||
char *str;
|
||||
char *Name;
|
||||
{
|
||||
int ch, ch2;
|
||||
int quoted();
|
||||
|
||||
while (*str) {
|
||||
if (*str == '\\') {
|
||||
ch = quoted(&str);
|
||||
}
|
||||
else {
|
||||
ch = *str++;
|
||||
}
|
||||
if (*str == '-') {
|
||||
if (*++str == '\\') {
|
||||
ch2 = quoted(&str);
|
||||
}
|
||||
else {
|
||||
if (ch2 = *str++);
|
||||
else str--;
|
||||
}
|
||||
if (ch > ch2) {
|
||||
fprintf(stderr, "%s: bad range\n", ProgCall);
|
||||
return 0;
|
||||
}
|
||||
if (ch >= 0 && ch2 <= 255)
|
||||
while (ch <= ch2)
|
||||
Table[ch++] = Salloc(Name);
|
||||
}
|
||||
else {
|
||||
if (ch >= 0 && ch <= 255)
|
||||
Table[ch] = Salloc(Name);
|
||||
}
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
int
|
||||
quoted(pstr)
|
||||
char **pstr;
|
||||
{
|
||||
register int ch;
|
||||
register int i;
|
||||
register char *str = *pstr;
|
||||
|
||||
if ((*++str >= '0') && (*str <= '9')) {
|
||||
ch = 0;
|
||||
for (i = 0; i < 3; i++) {
|
||||
ch = 8 * ch + *str - '0';
|
||||
if (*++str < '0' || *str > '9')
|
||||
break;
|
||||
}
|
||||
}
|
||||
else {
|
||||
switch (*str++) {
|
||||
|
||||
case 'n':
|
||||
ch = '\n';
|
||||
break;
|
||||
case 't':
|
||||
ch = '\t';
|
||||
break;
|
||||
case 'b':
|
||||
ch = '\b';
|
||||
break;
|
||||
case 'r':
|
||||
ch = '\r';
|
||||
break;
|
||||
case 'f':
|
||||
ch = '\f';
|
||||
break;
|
||||
default :
|
||||
ch = *str;
|
||||
}
|
||||
}
|
||||
*pstr = str;
|
||||
return ch & 0377;
|
||||
}
|
||||
|
||||
int
|
||||
stoi(str)
|
||||
char *str;
|
||||
{
|
||||
register i = 0;
|
||||
|
||||
while (*str >= '0' && *str <= '9') {
|
||||
i = i * 10 + *str++ - '0';
|
||||
}
|
||||
return i;
|
||||
}
|
||||
|
||||
char *
|
||||
getline(s, n, fp)
|
||||
char *s;
|
||||
FILE *fp;
|
||||
{
|
||||
register c = getc(fp);
|
||||
char *str = s;
|
||||
|
||||
while (n--) {
|
||||
if (c == EOF) {
|
||||
return NULL;
|
||||
}
|
||||
else
|
||||
if (c == '\n') {
|
||||
*str++ = '\0';
|
||||
return s;
|
||||
}
|
||||
*str++ = c;
|
||||
c = getc(fp);
|
||||
}
|
||||
s[n - 1] = '\0';
|
||||
return s;
|
||||
}
|
||||
|
||||
#define BUFSIZE 1024
|
||||
|
||||
DoFile(name)
|
||||
char *name;
|
||||
{
|
||||
char text[BUFSIZE];
|
||||
FILE *fp;
|
||||
|
||||
if ((fp = fopen(name, "r")) == NULL) {
|
||||
fprintf(stderr, "%s: cannot read file %s\n", ProgCall, name);
|
||||
exit(1);
|
||||
}
|
||||
while (getline(text, BUFSIZE, fp) != NULL) {
|
||||
if (text[0] == FILECOM) {
|
||||
option(text);
|
||||
}
|
||||
else {
|
||||
process(text, InputForm);
|
||||
}
|
||||
}
|
||||
}
|
99
lang/m2/comp/tokenname.c
Normal file
99
lang/m2/comp/tokenname.c
Normal file
|
@ -0,0 +1,99 @@
|
|||
#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
|
||||
a grammar file (tokenfile.g) from this file. This scheme ensures
|
||||
that all tokens have a printable name.
|
||||
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"},
|
||||
{INTEGER, "integer"},
|
||||
{REAL, "real"},
|
||||
{0, ""}
|
||||
};
|
||||
|
||||
struct tokenname tkcomp[] = { /* names of the composite tokens */
|
||||
{UNEQUAL, "<>"},
|
||||
{LESSEQUAL, "<="},
|
||||
{GREATEREQUAL, ">="},
|
||||
{UPTO, ".."},
|
||||
{BECOMES, ":="},
|
||||
{0, ""}
|
||||
};
|
||||
|
||||
struct tokenname tkidf[] = { /* names of the identifier tokens */
|
||||
{AND, "AND"},
|
||||
{ARRAY, "ARRAY"},
|
||||
{BEGIN, "BEGIN"},
|
||||
{BY, "BY"},
|
||||
{CASE, "CASE"},
|
||||
{CONST, "CONST"},
|
||||
{DEFINITION, "DEFINITION"},
|
||||
{DIV, "DIV"},
|
||||
{DO, "DO"},
|
||||
{ELSE, "ELSE"},
|
||||
{ELSIF, "ELSIF"},
|
||||
{END, "END"},
|
||||
{EXIT, "EXIT"},
|
||||
{EXPORT, "EXPORT"},
|
||||
{FOR, "FOR"},
|
||||
{FROM, "FROM"},
|
||||
{IF, "IF"},
|
||||
{IMPLEMENTATION, "IMPLEMENTATION"},
|
||||
{IMPORT, "IMPORT"},
|
||||
{IN, "IN"},
|
||||
{LOOP, "LOOP"},
|
||||
{MOD, "MOD"},
|
||||
{MODULE, "MODULE"},
|
||||
{NOT, "NOT"},
|
||||
{OF, "OF"},
|
||||
{OR, "OR"},
|
||||
{POINTER, "POINTER"},
|
||||
{PROCEDURE, "PROCEDURE"},
|
||||
{QUALIFIED, "QUALIFIED"},
|
||||
{RECORD, "RECORD"},
|
||||
{REPEAT, "REPEAT"},
|
||||
{RETURN, "RETURN"},
|
||||
{SET, "SET"},
|
||||
{THEN, "THEN"},
|
||||
{TO, "TO"},
|
||||
{TYPE, "TYPE"},
|
||||
{UNTIL, "UNTIL"},
|
||||
{VAR, "VAR"},
|
||||
{WHILE, "WHILE"},
|
||||
{WITH, "WITH"},
|
||||
{0, ""}
|
||||
};
|
||||
|
||||
struct tokenname tkinternal[] = { /* internal keywords */
|
||||
{0, "0"}
|
||||
};
|
||||
|
||||
struct tokenname tkstandard[] = { /* standard identifiers */
|
||||
{0, ""}
|
||||
};
|
||||
|
||||
/* Some routines to handle tokennames */
|
||||
|
||||
reserve(resv)
|
||||
register struct tokenname *resv;
|
||||
{
|
||||
/* The names of the tokens described in resv are entered
|
||||
as reserved words.
|
||||
*/
|
||||
register struct idf *p;
|
||||
|
||||
while (resv->tn_symbol) {
|
||||
p = str2idf(resv->tn_name, 0);
|
||||
if (!p) fatal("Out of Memory");
|
||||
p->id_reserved = resv->tn_symbol;
|
||||
resv++;
|
||||
}
|
||||
}
|
7
lang/m2/comp/tokenname.h
Normal file
7
lang/m2/comp/tokenname.h
Normal file
|
@ -0,0 +1,7 @@
|
|||
/* $Header$ */
|
||||
struct tokenname { /* Used for defining the name of a
|
||||
token as identified by its symbol
|
||||
*/
|
||||
int tn_symbol;
|
||||
char *tn_name;
|
||||
};
|
Loading…
Reference in a new issue