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

Initial revision

Browse source
This commit is contained in:
ceriel 1987-09-24 13:01:27 +00:00
parent a830d68fae
commit e30234fce8
30 changed files with 2914 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

445
lang/m2/m2mm/LLlex.c Normal file
View file

@ -0,0 +1,445 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* 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 */
/* $Header$ */
#include <alloc.h>
#include "idfsize.h"
#include "idf.h"
#include "LLlex.h"
#include "input.h"
#include "f_info.h"
#include "Lpars.h"
#include "class.h"
struct token dot,
aside;
int idfsize = IDFSIZE;
int ForeignFlag;
static int eofseen;
extern char options[];
STATIC
SkipComment()
{
/* Skip Modula-2 comments (* ... *).
Note that comments may be nested (par. 3.5).
*/
register int ch;
register int CommentLevel = 0;
LoadChar(ch);
if (ch == '$') {
LoadChar(ch);
switch(ch) {
case 'F':
/* Foreign; This definition module has an
implementation in another language.
In this case, check that the object file is present
and don't generate a rule for it.
*/
ForeignFlag = 1;
break;
default:
PushBack();
break;
}
}
for (;;) {
if (class(ch) == STNL) {
LineNumber++;
}
else if (ch == '(') {
LoadChar(ch);
if (ch == '*') CommentLevel++;
else continue;
}
else if (ch == '*') {
LoadChar(ch);
if (ch == ')') {
CommentLevel--;
if (CommentLevel < 0) break;
}
else continue;
}
else if (ch == EOI) {
lexerror("unterminated comment");
break;
}
LoadChar(ch);
}
}
STATIC
GetString(upto)
{
/* Read a Modula-2 string, delimited by the character "upto".
*/
register int ch;
register char *p;
while (LoadChar(ch), ch != upto) {
if (class(ch) == STNL) {
lexerror("newline in string");
LineNumber++;
break;
}
if (ch == EOI) {
lexerror("end-of-file in string");
break;
}
}
}
static char *s_error = "illegal line directive";
STATIC int
getch()
{
register int ch;
for (;;) {
LoadChar(ch);
if ((ch & 0200) && ch != EOI) {
error("non-ascii '\\%03o' read", ch & 0377);
continue;
}
break;
}
if (ch == EOI) {
eofseen = 1;
return '\n';
}
return ch;
}
CheckForLineDirective()
{
register int ch = getch();
register int i = 0;
char buf[IDFSIZE + 2];
register char *c = buf;
if (ch != '#') {
PushBack();
return;
}
do { /*
* Skip to next digit
* Do not skip newlines
*/
ch = getch();
if (class(ch) == STNL) {
LineNumber++;
error(s_error);
return;
}
} while (class(ch) != STNUM);
while (class(ch) == STNUM) {
i = i*10 + (ch - '0');
ch = getch();
}
while (ch != '"' && class(ch) != STNL) ch = getch();
if (ch == '"') {
c = buf;
do {
*c++ = ch = getch();
if (class(ch) == STNL) {
LineNumber++;
error(s_error);
return;
}
} while (ch != '"');
*--c = '\0';
do {
ch = getch();
} while (class(ch) != STNL);
/*
* Remember the file name
*/
if (!eofseen && strcmp(FileName,buf)) {
FileName = Salloc(buf,(unsigned) strlen(buf) + 1);
}
}
if (eofseen) {
error(s_error);
return;
}
LineNumber = i;
}
char idfbuf[IDFSIZE + 2];
int
LLlex()
{
/* LLlex() is the Lexical Analyzer.
The putting aside of tokens is taken into account.
*/
register struct token *tk = &dot;
register int ch, nch;
if (ASIDE) { /* a token is put aside */
*tk = aside;
ASIDE = 0;
return tk->tk_symb;
}
again1:
if (eofseen) {
eofseen = 0;
ch = EOI;
}
else {
again:
LoadChar(ch);
if ((ch & 0200) && ch != EOI) {
error("non-ascii '\\%03o' read", ch & 0377);
goto again;
}
}
tk->tk_lineno = LineNumber;
switch (class(ch)) {
case STNL:
LineNumber++;
CheckForLineDirective();
goto again1;
case STSKIP:
goto again;
case STGARB:
if ((unsigned) ch - 040 < 0137) {
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 if (nch == EOI) eofseen = 1;
else PushBack();
}
if (ch == '&') return tk->tk_symb = AND;
if (ch == '~') return tk->tk_symb = NOT;
return tk->tk_symb = ch;
case STCOMP:
LoadChar(nch);
switch (ch) {
case '.':
if (nch == '.') {
return tk->tk_symb = UPTO;
}
break;
case ':':
if (nch == '=') {
return tk->tk_symb = BECOMES;
}
break;
case '<':
if (nch == '=') {
return tk->tk_symb = LESSEQUAL;
}
if (nch == '>') {
return tk->tk_symb = '#';
}
break;
case '>':
if (nch == '=') {
return tk->tk_symb = GREATEREQUAL;
}
break;
default :
crash("(LLlex, STCOMP)");
}
if (nch == EOI) eofseen = 1;
else PushBack();
return tk->tk_symb = ch;
case STIDF:
{
register char *tag = &idfbuf[0];
register struct idf *id;
do {
if (tag - idfbuf < idfsize) *tag++ = ch;
LoadChar(ch);
} while(in_idf(ch));
if (ch == EOI) eofseen = 1;
else PushBack();
*tag++ = '\0';
tk->TOK_IDF = id = findidf(idfbuf);
return tk->tk_symb = id && id->id_reserved ? id->id_reserved : IDENT;
}
case STSTR:
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.
*/
enum statetp {Oct,OptHex,Hex,Dec,OctEndOrHex,End,OptReal,Real};
register enum statetp state;
state = is_oct(ch) ? Oct : Dec;
LoadChar(ch);
for (;;) {
switch(state) {
case Oct:
while (is_oct(ch)) {
LoadChar(ch);
}
if (ch == 'B' || ch == 'C') {
state = OctEndOrHex;
break;
}
/* Fall Through */
case Dec:
while (is_dig(ch)) {
LoadChar(ch);
}
if (ch == 'D') state = OptHex;
else if (is_hex(ch)) state = Hex;
else if (ch == '.') state = OptReal;
else {
state = End;
if (ch == 'H') ;
else if (ch == EOI) eofseen = 1;
else PushBack();
}
break;
case OptHex:
LoadChar(ch);
if (is_hex(ch)) {
state = Hex;
}
else state = End;
break;
case Hex:
while (is_hex(ch)) {
LoadChar(ch);
}
state = End;
if (ch != 'H') {
lexerror("H expected after hex number");
if (ch == EOI) eofseen = 1;
else PushBack();
}
break;
case OctEndOrHex:
LoadChar(ch);
if (ch == 'H') {
state = End;
break;
}
if (is_hex(ch)) {
state = Hex;
break;
}
if (ch == EOI) eofseen = 1;
else PushBack();
/* Fall through */
case End:
return tk->tk_symb = INTEGER;
case OptReal:
/* The '.' 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();
PushBack();
state = End;
break;
}
state = Real;
break;
}
if (state == Real) break;
}
while (is_dig(ch)) {
/* Fractional part
*/
LoadChar(ch);
}
if (ch == 'E' || ch == 'D') {
/* Scale factor
*/
if (ch == 'D') {
LoadChar(ch);
if (!(ch == '+' || ch == '-' || is_dig(ch)))
goto noscale;
}
LoadChar(ch);
if (ch == '+' || ch == '-') {
/* Signed scalefactor
*/
LoadChar(ch);
}
if (is_dig(ch)) {
do {
LoadChar(ch);
} while (is_dig(ch));
}
else {
lexerror("bad scale factor");
}
}
noscale:
if (ch == EOI) eofseen = 1;
else PushBack();
return tk->tk_symb = REAL;
/*NOTREACHED*/
}
case STEOI:
return tk->tk_symb = -1;
case STCHAR:
default:
crash("(LLlex) Impossible character class");
/*NOTREACHED*/
}
/*NOTREACHED*/
}

28
lang/m2/m2mm/LLlex.h Normal file
View file

@ -0,0 +1,28 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* 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 */
/* stripped down version of the one in the Modula-2 compiler */
/* $Header$ */
/* Token structure. Keep it small, as it is part of a parse-tree node
*/
struct token {
short tk_symb; /* token itself */
unsigned short tk_lineno; /* linenumber on which it occurred */
struct idf *tk_idf; /* IDENT */
};
#define TOK_IDF tk_idf
extern struct token dot, aside;
extern int ForeignFlag;
#define DOT dot.tk_symb
#define ASIDE aside.tk_symb

52
lang/m2/m2mm/LLmessage.c Normal file
View file

@ -0,0 +1,52 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* S Y N T A X E R R O R R E P O R T I N G */
/* stripped down version from the one in the Modula-2 compiler */
/* $Header$ */
/* Defines the LLmessage routine. LLgen-generated parsers require the
existence of a routine of that name.
The routine must do syntax-error reporting and must be able to
insert tokens in the token stream.
*/
#include "idf.h"
#include "LLlex.h"
#include "Lpars.h"
extern char *symbol2str();
extern struct idf *gen_anon_idf();
LLmessage(tk)
register int tk;
{
if (tk > 0) {
/* if (tk > 0), it represents the token to be inserted.
*/
register struct token *dotp = &dot;
error("%s missing", symbol2str(tk));
aside = *dotp;
dotp->tk_symb = tk;
switch (tk) {
/* The operands need some body */
case IDENT:
dotp->TOK_IDF = gen_anon_idf();
break;
}
}
else if (tk < 0) {
error("garbage at end of program");
}
else error("%s deleted", symbol2str(dot.tk_symb));
}

147
lang/m2/m2mm/Makefile Normal file
View file

@ -0,0 +1,147 @@
#
EMHOME = ../../..
MHDIR = $(EMHOME)/modules/h
PKGDIR = $(EMHOME)/modules/pkg
LIBDIR = $(EMHOME)/modules/lib
LLGEN = $(EMHOME)/bin/LLgen
MKDEP = $(EMHOME)/bin/mkdep
INCLUDES = -I$(MHDIR) -I$(PKGDIR) -I$(EMHOME)/h
GF = program.g declar.g expression.g statement.g
GENGFILES= tokenfile.g
GFILES =$(GENGFILES) $(GF)
LLGENOPTIONS = -v
PROFILE =
CFLAGS = $(PROFILE) $(INCLUDES) -DSTATIC=
LINTFLAGS = -DSTATIC= -DNORCSID
MALLOC = $(LIBDIR)/malloc.o
LDFLAGS = -i $(PROFILE)
LSRC = tokenfile.c program.c declar.c expression.c statement.c
LOBJ = tokenfile.o program.o declar.o expression.o statement.o
CSRC = LLlex.c LLmessage.c error.c main.c lib.c \
tokenname.c idf.c input.c misc.c options.c
COBJ = LLlex.o LLmessage.o error.o main.o lib.o \
tokenname.o idf.o input.o misc.o options.o char.o symbol2str.o
GENC= $(LSRC) symbol2str.c char.c Lpars.c
SRC = $(CSRC) $(GENC)
OBJ = $(COBJ) $(LOBJ) Lpars.o
GENH = Lpars.h
HSRC = main.h LLlex.h class.h f_info.h idf.h input.h tokenname.h
HFILES =$(GENH) $(HSRC)
#
GENFILES = $(GENGFILES) $(GENC) $(GENH)
all: Cfiles
make "EMHOME="$(EMHOME) m2mm
install: all
cp m2mm $(EMHOME)/bin
cmp: all
cmp m2mm $(EMHOME)/bin/m2mm
opr:
make "EMHOME="$(EMHOME) pr | opr
pr:
@pr Makefile $(GF) $(HFILES) $(CSRC)
clean:
rm -f $(OBJ) $(GENFILES) LLfiles Cfiles tab LL.output
lint: Cfiles
lint $(INCLUDES) $(LINTFLAGS) $(SRC) \
$(LIBDIR)/llib-linput.ln \
$(LIBDIR)/llib-lalloc.ln \
$(LIBDIR)/llib-lprint.ln \
$(LIBDIR)/llib-lstring.ln \
$(LIBDIR)/llib-lsystem.ln
# entry points not to be used directly
Cfiles: LLfiles $(GENC) $(GENH) Makefile
LLfiles: $(GFILES)
$(LLGEN) $(LLGENOPTIONS) $(GFILES)
@touch 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
char.c: char.tab tab
tab -fchar.tab >char.c
tab:
$(CC) tab.c -o tab
depend: Cfiles
sed '/^#AUTOAUTO/,$$d' Makefile > Makefile.new
echo '#AUTOAUTOAUTOAUTOAUTOAUTOAUTOAUTO' >> Makefile.new
$(MKDEP) $(SRC) |\
sed 's/\.c:/\.o:/' >> Makefile.new
mv Makefile Makefile.old
mv Makefile.new Makefile
m2mm: $(OBJ)
$(CC) $(LDFLAGS) $(OBJ) $(LIBDIR)/libinput.a $(LIBDIR)/liballoc.a $(MALLOC) $(LIBDIR)/libprint.a $(LIBDIR)/libstring.a $(LIBDIR)/libsystem.a -o m2mm
size m2mm
#AUTOAUTOAUTOAUTOAUTOAUTOAUTOAUTO
LLlex.o: LLlex.h
LLlex.o: Lpars.h
LLlex.o: class.h
LLlex.o: f_info.h
LLlex.o: file_list.h
LLlex.o: idf.h
LLlex.o: idfsize.h
LLlex.o: input.h
LLlex.o: inputtype.h
LLmessage.o: LLlex.h
LLmessage.o: Lpars.h
LLmessage.o: file_list.h
LLmessage.o: idf.h
error.o: LLlex.h
error.o: f_info.h
error.o: input.h
error.o: inputtype.h
main.o: LLlex.h
main.o: Lpars.h
main.o: f_info.h
main.o: file_list.h
main.o: idf.h
main.o: input.h
main.o: inputtype.h
main.o: tokenname.h
tokenname.o: Lpars.h
tokenname.o: file_list.h
tokenname.o: idf.h
tokenname.o: tokenname.h
idf.o: file_list.h
idf.o: idf.h
input.o: f_info.h
input.o: input.h
input.o: inputtype.h
misc.o: LLlex.h
misc.o: f_info.h
misc.o: file_list.h
misc.o: idf.h
options.o: main.h
tokenfile.o: Lpars.h
program.o: LLlex.h
program.o: Lpars.h
program.o: f_info.h
program.o: file_list.h
program.o: idf.h
program.o: main.h
declar.o: Lpars.h
expression.o: Lpars.h
statement.o: LLlex.h
statement.o: Lpars.h
statement.o: file_list.h
statement.o: idf.h
symbol2str.o: Lpars.h
char.o: class.h
Lpars.o: Lpars.h

54
lang/m2/m2mm/char.tab Normal file
View 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-Z0-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};

45
lang/m2/m2mm/class.h Normal file
View file

@ -0,0 +1,45 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* 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) ((unsigned)ch < 0177 && inidf[ch])
#define is_oct(ch) ((unsigned)ch < 0177 && isoct[ch])
#define is_dig(ch) ((unsigned)ch < 0177 && isdig[ch])
#define is_hex(ch) ((unsigned)ch < 0177 && ishex[ch])
extern char tkclass[];
extern char inidf[], isoct[], isdig[], ishex[];

266
lang/m2/m2mm/declar.g Normal file
View file

@ -0,0 +1,266 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* D E C L A R A T I O N S */
/* stripped down version of the one in the Modula-2 compiler */
/* $Header$ */
ProcedureHeading :
PROCEDURE IDENT
[
'('
[
FPSection
[
';' FPSection
]*
]?
')'
[ ':' qualtype
]?
]?
;
block :
[ %persistent
declaration
]*
[ %default
BEGIN
StatementSequence
|
]
END
;
declaration :
CONST [ ConstantDeclaration ';' ]*
|
TYPE [ TypeDeclaration ';' ]*
|
VAR [ VariableDeclaration ';' ]*
|
ProcedureHeading ';'
block
IDENT
';'
|
ModuleDeclaration ';'
;
FPSection :
var IdentList ':' FormalType
;
FormalType :
ARRAY OF qualtype
|
qualtype
;
TypeDeclaration :
IDENT
'=' type
;
type :
%default SimpleType
|
ArrayType
|
RecordType
|
SetType
|
PointerType
|
ProcedureType
;
SimpleType :
qualtype
[
/* nothing */
|
SubrangeType
/* The subrange type is given a base type by the
qualident (this is new modula-2).
*/
]
|
enumeration
|
SubrangeType
;
enumeration :
'(' IdentList ')'
;
IdentList :
IDENT
[ %persistent
',' IDENT
]*
;
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 :
[
IdentList ':' type
|
CASE
/* Also accept old fashioned Modula-2 syntax, but give a warning.
Sorry for the complicated code.
*/
[ qualident
[ ':' qualtype
/* This is correct, in both kinds of Modula-2, if
the first qualident is a single identifier.
*/
| /* Old fashioned! the first qualident now represents
the type
*/
]
| ':' qualtype
/* Aha, third edition. Well done! */
]
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
;
/* In a pointer type definition, the type pointed at does not
have to be declared yet, so be careful about identifying
type-identifiers
*/
PointerType :
POINTER TO type
;
qualtype :
qualident
;
ProcedureType :
PROCEDURE
[
FormalTypeList
|
]
;
FormalTypeList :
'('
[
VarFormalType
[
',' VarFormalType
]*
]?
')'
[ ':' qualtype
|
]
;
VarFormalType :
var
FormalType
;
var :
[
VAR
|
/* empty */
]
;
ConstantDeclaration :
IDENT
'=' ConstExpression
;
VariableDeclaration :
IdentAddr
[ %persistent
',' IdentAddr
]*
':' type
;
IdentAddr :
IDENT
[ '['
ConstExpression
']'
]?
;

146
lang/m2/m2mm/error.c Normal file
View file

@ -0,0 +1,146 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* 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 */
/* stripped down version from the one in the Modula-2 compiler */
/* $Header$ */
/* 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 <system.h>
#include "input.h"
#include "f_info.h"
#include "LLlex.h"
/* error classes */
#define ERROR 1
#define LEXERROR 3
#define CRASH 5
#define FATAL 6
int err_occurred;
extern char *symbol2str();
/* There are three general error-message functions:
lexerror() lexical and pre-processor error messages
error() syntactic and semantic error messages
node_error() errors in nodes
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, node errors get their information from the
node, whereas other errors use the information in the token.
*/
/*VARARGS1*/
error(fmt, args)
char *fmt;
{
_error(ERROR, fmt, &args);
}
/*VARARGS1*/
Gerror(fmt, args)
char *fmt;
{
char *fn = FileName;
FileName = 0;
_error(ERROR, fmt, &args);
FileName = fn;
}
/*VARARGS1*/
lexerror(fmt, args)
char *fmt;
{
_error(LEXERROR, fmt, &args);
}
/*VARARGS1*/
fatal(fmt, args)
char *fmt;
int args;
{
_error(FATAL, fmt, &args);
sys_stop(S_EXIT);
}
/*VARARGS1*/
crash(fmt, args)
char *fmt;
int args;
{
_error(CRASH, fmt, &args);
#ifdef DEBUG
sys_stop(S_ABORT);
#else
sys_stop(S_EXIT);
#endif
}
_error(class, fmt, argv)
int class;
char *fmt;
int argv[];
{
/* _error attempts to limit the number of error messages
for a given line to MAXERR_LINE.
*/
unsigned int ln = 0;
register 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:
case CRASH:
case FATAL:
err_occurred = 1;
break;
}
/* the remark */
switch (class) {
case CRASH:
remark = "CRASH\007";
break;
case FATAL:
remark = "fatal error --";
break;
}
/* the place */
switch (class) {
case ERROR:
ln = dot.tk_lineno;
break;
case LEXERROR:
case CRASH:
case FATAL:
ln = LineNumber;
break;
}
if (FileName) fprint(STDERR, "\"%s\", line %u: ", FileName, ln);
if (remark) fprint(STDERR, "%s ", remark);
doprnt(STDERR, fmt, argv); /* contents of error */
fprint(STDERR, "\n");
}

146
lang/m2/m2mm/expression.g Normal file
View file

@ -0,0 +1,146 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* E X P R E S S I O N S */
/* stripped down version of the one in the Modula-2 compiler */
/* $Header$ */
qualident :
IDENT
[
selector
]*
;
selector :
'.' IDENT
;
ExpList :
expression
[
','
expression
]*
;
ConstExpression :
expression
/*
* Changed rule in new Modula-2.
*/
;
expression :
SimpleExpression
[
/* relation */
[ '=' | '#' | '<' | LESSEQUAL | '>' | GREATEREQUAL | IN ]
SimpleExpression
]?
;
SimpleExpression :
[
[ '+' | '-' ]
]?
term
[
/* AddOperator */
[ '+' | '-' | OR ]
term
]*
;
term :
factor
[
/* MulOperator */
[ '*' | '/' | DIV | MOD | AND ]
factor
]*
;
factor :
qualident
[
designator_tail?
[
ActualParameters
]?
|
bare_set
]
|
bare_set
| %default
[
%default
INTEGER
|
REAL
|
STRING
]
|
'(' expression ')'
|
NOT factor
;
bare_set :
'{'
[
element
[
',' element
]*
]?
'}'
;
ActualParameters :
'(' ExpList? ')'
;
element :
expression
[
UPTO
expression
]?
;
designator :
qualident
designator_tail?
;
designator_tail :
visible_designator_tail
[ %persistent
%default
selector
|
visible_designator_tail
]*
;
visible_designator_tail :
[
'['
expression
[
',' expression
]*
']'
|
'^'
]
;

21
lang/m2/m2mm/f_info.h Normal file
View file

@ -0,0 +1,21 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* 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 {
unsigned short 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
#define WorkingDir file_info.f_workingdir

6
lang/m2/m2mm/file_list.h Normal file
View file

@ -0,0 +1,6 @@
struct file_list {
char *a_filename;
char *a_dir;
struct idf *a_idf;
struct file_list *a_next;
};

13
lang/m2/m2mm/idf.c Normal file
View file

@ -0,0 +1,13 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* 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"
#include <idf_pkg.body>

40
lang/m2/m2mm/idf.h Normal file
View file

@ -0,0 +1,40 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* U S E R D E C L A R E D P A R T O F I D F */
/* $Header$ */
#include "file_list.h"
struct lnk {
struct lnk *lnk_next;
struct idf *lnk_imp;
};
struct id_u {
int id_res;
int id_tp; /* PROGRAM OR IMPLEMENTATION OR DEFINITION */
struct lnk *id_defimp; /* imported by definition module */
struct lnk *id_modimp; /* imported by implementation module */
char *id_d; /* directory */
struct file_list *id_mdep; /* module depends on: */
struct file_list *id_ddep; /* definition module depends on: */
char *id_df; /* name of definition module */
};
#define IDF_TYPE struct id_u
#define id_reserved id_user.id_res
#define id_type id_user.id_tp
#define id_defimports id_user.id_defimp
#define id_modimports id_user.id_modimp
#define id_dir id_user.id_d
#define id_mdependson id_user.id_mdep
#define id_ddependson id_user.id_ddep
#define id_def id_user.id_df
#include <idf_pkg.spec>

1
lang/m2/m2mm/idfsize.h Normal file
View file

@ -0,0 +1 @@
#define IDFSIZE 128 /* maximum significant length of an identifier */

31
lang/m2/m2mm/input.c Normal file
View file

@ -0,0 +1,31 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* 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"
struct f_info file_info;
#include "input.h"
#include <inp_pkg.body>
AtEoIF()
{
/* Make the unstacking of input streams noticable to the
lexical analyzer
*/
return 1;
}
AtEoIT()
{
/* Make the end of the text noticable
*/
return 1;
}

18
lang/m2/m2mm/input.h Normal file
View file

@ -0,0 +1,18 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* 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$ */
#include "inputtype.h"
#define INP_NPUSHBACK 2
#define INP_TYPE struct f_info
#define INP_VAR file_info
#include <inp_pkg.spec>

1
lang/m2/m2mm/inputtype.h Normal file
View file

@ -0,0 +1 @@
#define INP_READ_IN_ONE 1 /* read input file in one */

32
lang/m2/m2mm/lib.c Normal file
View file

@ -0,0 +1,32 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* L I B R A R Y */
/* $Header$ */
#include <em_path.h>
static char lib_dir[128] = EM_DIR;
is_library_dir(d)
char *d;
{
/* Check if directory d is a directory containing
"system" definition modules. Return 1 if it is, 0 otherwise.
*/
return strcmp(lib_dir, d) == 0 ? 1 : 0;
}
init_lib()
{
extern char *strcat();
strcat(lib_dir, "/lib/m2");
AddInclDir(lib_dir);
}

44
lang/m2/m2mm/m2mm.1 Normal file
View file

@ -0,0 +1,44 @@
.TH M2MM 1ACK
.ad
.SH NAME
m2mm \- Modula-2 makefile generator
.SH SYNOPSIS
\fBm2mm\fP [ \fB-I\fPdir \fB-M\fPflags \fB-C\fPcompiler \fB-S\fPsuffix ] file ...
.SH DESCRIPTION
.I M2mm
is a makefile generator and fast syntax checker for Modula-2 programs.
The makefile is produced on standard output.
.I M2mm
will generate rules to produce an object file
for every module used in the argument files.
In addition, it will generate a rule to make a program, for each of the
program modules given as argument.
Using
.IR make (1)
without an argument will make all these programs.
.PP
In the makefile, the variables \fBMOD\fP, \fBM2FLAGS\fP, \fBIFLAGS\fP, and
\fBSUFFIX\fP will be defined.
The generated rules have the following form:
.DS
\fIname\fP.$(SUFFIX): ...
$(MOD) -c $(M2FLAGS) $(IFLAGS) \fIname\fP.mod
.DE
.I M2mm
recognizes the following options:
.IP \fB-I\fP\fIdir\fP
Add \fIdir\fP to the list of directories where definition modules are
looked for. Also add the flag to \fBIFLAGS\fP.
The default value for \fBIFLAGS\fP is empty.
.IP \fB-M\fP\fIflags\fP
Set \fBM2FLAGS\fP to \fIflags\fP.
.IP \fB-C\fP\fIcompiler\fP
Set \fBMOD\fP to \fIcompiler\fP.
The default value for \fBMOD\fP is "ack" (for the time being).
.IP \fB-S\fPsuffix
Set \fBSUFFIX\fP to \fIsuffix\fP.
The default suffix is "o".
.SH SEE ALSO
.IR make "(1), " modula-2 (1)
.SH DIAGNOSTICS
Are intended to be self-explanatory.

412
lang/m2/m2mm/main.c Normal file
View file

@ -0,0 +1,412 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* M A I N P R O G R A M */
/* stripped down version from the one in the Modula-2 compiler */
/* $Header$ */
#include <alloc.h>
#include "input.h"
#include "f_info.h"
#include "idf.h"
#include "LLlex.h"
#include "Lpars.h"
#include "tokenname.h"
int state; /* either IMPLEMENTATION or PROGRAM */
char options[128];
int DefinitionModule;
char *ProgName;
char **DEFPATH;
int nDEF, mDEF;
struct file_list *CurrentArg;
extern int err_occurred;
extern int Roption;
extern char *strrindex();
extern char *strcpy(), *strcat();
char *
getwdir(fn)
register char *fn;
{
register char *p;
p = strrindex(fn, '/');
while (p && *(p + 1) == '\0') { /* remove trailing /'s */
*p = '\0';
p = strrindex(fn, '/');
}
if (p) {
register char **d = DEFPATH;
*p = '\0';
while (*d && strcmp(*d, fn) != 0) d++;
if (*d) {
*p = '/';
return *d;
}
fn = Salloc(fn, (unsigned) (p - &fn[0] + 1));
*p = '/';
return fn;
}
return ".";
}
static struct file_list *arglist;
char *mflags = "";
char *compiler = "ack";
char *suff = "o";
main(argc, argv)
register char **argv;
{
extern struct tokenname tkidf[];
extern char *getwdir();
int i;
ProgName = *argv++;
DEFPATH = (char **) Malloc(10 * sizeof(char *));
mDEF = 10;
nDEF = 1;
while (--argc > 0) {
if (**argv == '-')
DoOption((*argv++) + 1);
else {
Add(&arglist, *argv, getwdir(*argv), 1);
argv++;
}
}
init_idf();
reserve(tkidf);
print("IFLAGS =");
for (i = 1; i < nDEF; i++) {
print(" -I%s", DEFPATH[i]);
}
print("\nM2FLAGS = %s\nMOD = %s\nSUFFIX = %s\n", mflags, compiler, suff);
init_lib();
ProcessArgs();
find_dependencies();
print_dep();
programs();
exit(err_occurred);
}
struct file_list *
new_file_list()
{
static struct file_list *p;
static int cnt;
extern char *calloc();
if (cnt--) return p++;
p = (struct file_list *)calloc(50, sizeof(struct file_list));
cnt = 49;
return p++;
}
Add(parglist, f, d, copy)
char *f, *d;
struct file_list **parglist;
{
register struct file_list *a = *parglist, *b = 0;
while (a && strcmp(a->a_filename, f) != 0) {
b = a;
a = a->a_next;
}
if (a) return 0;
a = new_file_list();
if (copy) {
a->a_filename = Salloc(f, (unsigned) (strlen(f)+1));
}
else {
a->a_filename = f;
}
a->a_dir = d;
if (! b) *parglist = a;
else b->a_next = a;
return 1;
}
ProcessArgs()
{
register struct file_list *a = arglist;
char *fn;
while (a) {
register char *p = strrindex(a->a_filename, '.');
CurrentArg = a;
DEFPATH[0] = a->a_dir;
if ( p && strcmp(p, ".def") == 0) {
ForeignFlag = 0;
if (! InsertFile(a->a_filename, DEFPATH, &fn)) {
Gerror("Could not find %s", a->a_filename);
a = a->a_next;
continue;
}
FileName = fn;
a->a_dir = WorkingDir = getwdir(FileName);
DefModule();
}
else if (p && strcmp(p, ".mod") == 0) {
if (! InsertFile(a->a_filename, DEFPATH, &fn)) {
Gerror("Could not find %s", a->a_filename);
*p = 0; /* prevent from being used
later
*/
a->a_filename = Salloc(a->a_filename,
strlen(a->a_filename) +
11);
strcat(a->a_filename, ".$(SUFFIX)");
a = a->a_next;
continue;
}
FileName = fn;
a->a_dir = WorkingDir = getwdir(FileName);
CompUnit();
}
else fatal("No Modula-2 file: %s", a->a_filename);
a = a->a_next;
}
}
No_Mem()
{
fatal("out of memory");
}
C_failed()
{
fatal("write failed");
}
AddToList(name, ext)
char *name, *ext;
{
/* Try to find a file with basename "name" and extension ".def",
in the directories mentioned in "DEFPATH".
*/
char buf[15];
char *strncpy();
if (strcmp(name, "SYSTEM") != 0 && ! is_library_dir(WorkingDir)) {
strncpy(buf, name, 10);
buf[10] = '\0'; /* maximum length */
strcat(buf, ext);
Add(&arglist, buf, WorkingDir, 1);
return 1;
}
return 0;
}
find_dependencies()
{
register struct file_list *arg = arglist;
print("\nall:\t");
while (arg) {
char *dotspot = strrindex(arg->a_filename, '.');
if (dotspot && strcmp(dotspot, ".mod") == 0) {
register struct idf *id = arg->a_idf;
if (id) {
if (id->id_type == PROGRAM) {
print("%s ", id->id_text);
}
file_dep(id);
}
}
arg = arg->a_next;
}
print("\n\n");
}
file_dep(id)
register struct idf *id;
{
register struct lnk *m;
if (id->id_ddependson || id->id_mdependson) return;
if (id->id_def) Add(&(id->id_mdependson), id->id_def, id->id_dir, 0);
for (m = id->id_defimports; m; m = m->lnk_next) {
register struct idf *iid = m->lnk_imp;
Add(&(id->id_mdependson), iid->id_def, iid->id_dir, 0);
if (Add(&(id->id_ddependson), iid->id_def, iid->id_dir, 0)) {
register struct file_list *p;
file_dep(iid);
for (p = iid->id_ddependson; p; p = p->a_next) {
Add(&(id->id_ddependson), p->a_filename,
p->a_dir, 0);
Add(&(id->id_mdependson), p->a_filename,
p->a_dir, 0);
}
}
}
for (m = id->id_modimports; m; m = m->lnk_next) {
register struct idf *iid = m->lnk_imp;
if (Add(&(id->id_mdependson), iid->id_def, iid->id_dir, 0)) {
register struct file_list *p;
file_dep(iid);
for (p = iid->id_ddependson; p; p = p->a_next) {
Add(&(id->id_mdependson), p->a_filename,
p->a_dir, 0);
}
}
}
}
char *
object(arg)
register struct file_list *arg;
{
static char buf[512];
char *dotp = strrindex(arg->a_filename, '.');
buf[0] = 0;
/*
if (strcmp(arg->a_dir, ".") != 0) {
strcpy(buf, arg->a_dir);
strcat(buf, "/");
}
*/
*dotp = 0;
strcat(buf, arg->a_filename);
*dotp = '.';
strcat(buf, ".$(SUFFIX)");
return buf;
}
pr_arg(a)
register struct file_list *a;
{
if (strcmp(a->a_dir, ".") == 0) {
print(a->a_filename);
}
else print("%s/%s", a->a_dir, a->a_filename);
}
print_dep()
{
register struct file_list *arg = arglist;
while (arg) {
char *dotspot = strrindex(arg->a_filename, '.');
if (dotspot && strcmp(dotspot, ".mod") == 0) {
register struct idf *id = arg->a_idf;
if (id) {
char *obj = object(arg);
register struct file_list *a;
print("%s: \\\n\t", obj);
pr_arg(arg);
for (a = id->id_mdependson; a; a = a->a_next) {
print(" \\\n\t");
pr_arg(a);
}
print("\n\t$(MOD) -c $(M2FLAGS) $(IFLAGS) ");
pr_arg(arg);
print("\n");
}
}
arg = arg->a_next;
}
}
prog_dep(id)
register struct idf *id;
{
register struct lnk *m;
register struct file_list *p;
id->id_mdependson = 0;
id->id_def = 0;
if (strlen(id->id_text) >= 10) id->id_text[10] = 0;
Add(&(id->id_mdependson), id->id_text, id->id_dir, 0);
for (m = id->id_modimports; m; m = m->lnk_next) {
register struct idf *iid = m->lnk_imp;
if (Add(&(id->id_mdependson), iid->id_text, iid->id_dir, 0)) {
if (iid->id_def) prog_dep(iid);
for (p = iid->id_mdependson; p; p = p->a_next) {
Add(&(id->id_mdependson), p->a_filename,
p->a_dir, 0);
}
}
}
}
module_in_arglist(n)
char *n;
{
register struct file_list *a;
for (a = arglist; a; a = a->a_next) {
char *dotp = strrindex(a->a_filename, '.');
if (dotp && strcmp(dotp, ".mod") == 0) {
*dotp = 0;
if (strcmp(a->a_filename, n) == 0) {
*dotp = '.';
return 1;
}
*dotp = '.';
}
}
return 0;
}
pr_prog_dep(id)
register struct idf *id;
{
register struct file_list *p;
print("\nOBS_%s = ", id->id_text);
for (p = id->id_mdependson; p; p = p->a_next) {
if (module_in_arglist(p->a_filename)) {
print("\\\n\t%s.$(SUFFIX)", p->a_filename);
}
else if (! is_library_dir(p->a_dir)) {
print("\\\n\t%s/%s.$(SUFFIX)", p->a_dir, p->a_filename);
}
}
print("\n\n");
print("%s:\t$(OBS_%s)\n", id->id_text, id->id_text);
print("\t$(MOD) -.mod -o %s $(M2FLAGS) $(OBS_%s)\n", id->id_text, id->id_text);
}
programs()
{
register struct file_list *a;
for (a = arglist; a; a = a->a_next) {
char *dotspot = strrindex(a->a_filename, '.');
if (dotspot && strcmp(dotspot, ".mod") == 0) {
register struct idf *id = a->a_idf;
if (id && id->id_type == PROGRAM) {
prog_dep(id);
pr_prog_dep(id);
}
}
}
}

17
lang/m2/m2mm/main.h Normal file
View file

@ -0,0 +1,17 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* S O M E G L O B A L V A R I A B L E S */
/* $Header$ */
extern char options[]; /* indicating which options were given */
extern char **DEFPATH; /* search path for DEFINITION MODULE's */
extern int mDEF, nDEF;
extern int state; /* either IMPLEMENTATION or PROGRAM */
extern struct file_list *CurrentArg;

34
lang/m2/m2mm/make.tokcase Executable file
View 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/m2mm/make.tokfile Executable file
View file

@ -0,0 +1,6 @@
sed '
/{[A-Z]/!d
s/.*{//
s/,.*//
s/.*/%token &;/
'

31
lang/m2/m2mm/misc.c Normal file
View file

@ -0,0 +1,31 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* M I S C E L L A N E O U S R O U T I N E S */
/* stripped version from the one in the Modula-2 compiler */
/* $Header$ */
#include "f_info.h"
#include "idf.h"
#include "LLlex.h"
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 *sprint();
sprint(buff, "#%d in %s, line %u",
++name_cnt, FileName, LineNumber);
return str2idf(buff, 1);
}

80
lang/m2/m2mm/options.c Normal file
View file

@ -0,0 +1,80 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* U S E R O P T I O N - H A N D L I N G */
/* stripped down version from the one in the Modula-2 compiler */
/* $Header$ */
#include <alloc.h>
#include "main.h"
static int ndirs = 1;
DoOption(text)
register char *text;
{
extern char *mflags;
extern char *suff;
extern char *compiler;
switch(*text++) {
case 'I' :
AddInclDir(text);
break;
case 'M':
mflags = text;
break;
case 'C':
compiler = text;
break;
case 'S':
suff = text;
break;
default:
Gerror("Unrecognized option: -%s", text-1);
break;
}
}
AddInclDir(text)
char *text;
{
register int i;
register char *new = text;
if (! *text) {
DEFPATH[ndirs] = 0;
return;
}
if (++nDEF > mDEF) {
char **n = (char **)
Malloc((unsigned)((10+mDEF)*sizeof(char *)));
for (i = 0; i < mDEF; i++) {
n[i] = DEFPATH[i];
}
free((char *) DEFPATH);
DEFPATH = n;
mDEF += 10;
}
i = ndirs++;
while (new) {
register char *tmp = DEFPATH[i];
DEFPATH[i++] = new;
new = tmp;
}
}

237
lang/m2/m2mm/program.g Normal file
View file

@ -0,0 +1,237 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* O V E R A L L S T R U C T U R E */
/* stripped down version of the one in the Modula-2 compiler */
/* $Header$ */
/*
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 "main.h"
#include "idf.h"
#include "f_info.h"
#include "LLlex.h"
struct lnk *
new_lnk()
{
static struct lnk *p;
static int cnt;
extern char *calloc();
if (cnt--) return p++;
p = (struct lnk *)calloc(50, sizeof(struct lnk));
cnt = 49;
return p++;
}
}
%lexical LLlex;
%start CompUnit, CompilationUnit;
%start DefModule, DefinitionModule;
ModuleDeclaration :
MODULE IDENT
priority
';'
import((struct lnk **) 0)*
export?
block
IDENT
;
priority:
[
'[' ConstExpression ']'
|
]
;
export :
EXPORT
[
QUALIFIED
|
]
IdentList ';'
;
import(register struct lnk **p;)
{
register struct idf *fromid = 0;
struct idf *id;
}
:
{ if (p) while (*p) p = &((*p)->lnk_next); }
[ FROM
identifier(&id) { fromid = id;
if (p) {
if (AddToList(fromid->id_text, ".def")) {
*p = new_lnk();
(*p)->lnk_imp = fromid;
}
}
}
]?
IMPORT
identifier(&id) { if (! fromid && p) {
if (AddToList(id->id_text, ".def")) {
*p = new_lnk();
(*p)->lnk_imp = id;
p = &((*p)->lnk_next);
}
}
}
[
',' identifier(&id)
{ if (! fromid && p) {
if (AddToList(id->id_text, ".def")) {
*p = new_lnk();
(*p)->lnk_imp = id;
p = &((*p)->lnk_next);
}
}
}
]*
';'
/*
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
{
struct idf *id;
extern char *strrindex();
}
:
DEFINITION
MODULE identifier(&id)
{ if (! ForeignFlag) {
AddToList(id->id_text, ".mod");
}
if (! id->id_type) {
id->id_type = DEFINITION;
}
else if (id->id_type != IMPLEMENTATION) {
error("multiple declaration for module %s",
id->id_text);
}
if (! id->id_dir) {
id->id_dir = WorkingDir;
}
else if (strcmp(id->id_dir, WorkingDir)) {
Gerror("definition and implementation of module %s reside in different directories", id->id_text);
}
id->id_def = strrindex(FileName, '/');
if (! id->id_def) id->id_def = FileName;
else (id->id_def)++;
CurrentArg->a_idf = id;
}
';'
import(&(id->id_defimports))*
[
export
|
/* empty */
]
definition* END IDENT
'.'
;
definition :
CONST [ %persistent ConstantDeclaration ';' ]*
|
TYPE
[ %persistent
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 [ %persistent VariableDeclaration ';' ]*
|
ProcedureHeading
';'
;
ProgramModule
{
struct idf *id;
}
:
MODULE
identifier(&id) { if (! id->id_type) {
id->id_type = state;
}
else if (id->id_type != DEFINITION ||
state != IMPLEMENTATION) {
error("multiple declaration for module %s",
id->id_text);
}
if (! id->id_dir) {
id->id_dir = WorkingDir;
}
else if (strcmp(id->id_dir, WorkingDir)) {
Gerror("definition and implementation of module %s reside in different directories", id->id_text);
}
CurrentArg->a_idf = id;
}
priority
';' import(&(id->id_modimports))*
block IDENT
'.'
;
Module:
DEFINITION
{ fatal("Definition module in .mod file"); }
| %default
[
IMPLEMENTATION { state = IMPLEMENTATION; }
|
/* empty */ { state = PROGRAM; }
]
ProgramModule
;
CompilationUnit:
Module
;
identifier(struct idf **id;):
IDENT
{ extern char idfbuf[];
*id = str2idf(idfbuf);
}
;

136
lang/m2/m2mm/statement.g Normal file
View file

@ -0,0 +1,136 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* S T A T E M E N T S */
/* stripped down version from the one in the Modula-2 compiler */
/* $Header$ */
{
#include "idf.h"
#include "LLlex.h"
static int loopcount;
}
statement :
[
/*
* This part is not in the reference grammar. The reference grammar
* states : assignment | ProcedureCall | ...
* but this gives LL(1) conflicts
*/
designator
[
ActualParameters?
|
[ BECOMES
| '=' { error("':=' expected instead of '='");
DOT = BECOMES;
}
]
expression
]
/*
* end of changed part
*/
|
IfStatement
|
CaseStatement
|
WHILE
expression
DO
StatementSequence
END
|
REPEAT
StatementSequence
UNTIL
expression
|
{ loopcount++; }
LOOP
StatementSequence
END
{ loopcount--; }
|
ForStatement
|
WithStatement
|
EXIT
{ if (!loopcount) error("EXIT not in a LOOP"); }
|
ReturnStatement
|
/* empty */
]
;
StatementSequence :
statement
[ %persistent
';'
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
]?
;
ForStatement :
FOR IDENT BECOMES expression TO expression
[
BY ConstExpression
|
]
DO StatementSequence
END
;
WithStatement :
WITH designator DO StatementSequence
END
;
ReturnStatement :
RETURN
[
expression
|
]
;

295
lang/m2/m2mm/tab.c Normal file
View 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);
}
}
}

113
lang/m2/m2mm/tokenname.c Normal file
View file

@ -0,0 +1,113 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* T O K E N D E F I N I T I O N S */
/* $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
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.
*/
#ifdef ___XXX___
struct tokenname tkspec[] = { /* the names of the special tokens */
{IDENT, "identifier"},
{STRING, "string"},
{INTEGER, "number"},
{REAL, "real"},
{0, ""}
};
struct tokenname tkcomp[] = { /* names of the composite tokens */
{LESSEQUAL, "<="},
{GREATEREQUAL, ">="},
{UPTO, ".."},
{BECOMES, ":="},
{0, ""}
};
#endif
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, ""}
};
#ifdef ___XXX___
struct tokenname tkinternal[] = { /* internal keywords */
{PROGRAM, ""},
{COERCION, ""},
{0, "0"}
};
struct tokenname tkstandard[] = { /* standard identifiers */
{0, ""}
};
#endif
/* 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++;
}
}

17
lang/m2/m2mm/tokenname.h Normal file
View file

@ -0,0 +1,17 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* 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
*/
int tn_symbol;
char *tn_name;
};