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

newer version

Browse source
This commit is contained in:
ceriel 1986-07-08 14:59:02 +00:00
parent bcfca75b56
commit 965e75761d
16 changed files with 259 additions and 265 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

21
lang/m2/comp/Makefile
View file

@ -1,16 +1,16 @@
# make modula-2 "compiler"
# $Header$
EMDIR = /usr/em
MHDIR = $(EMDIR)/modules/h
PKGDIR = $(EMDIR)/modules/pkg
LIBDIR = $(EMDIR)/modules/lib
LLGEN = $(EMDIR)/util/LLgen/src/LLgen
HDIR = ../../em/h
PKGDIR = ../../em/pkg
LIBDIR = ../../em/lib
INCLUDES = -I$(HDIR) -I/usr/em/h -I$(PKGDIR) -I/user1/erikb/em/h
INCLUDES = -I$(MHDIR) -I$(EMDIR)/h -I$(PKGDIR)
LSRC = tokenfile.g program.g declar.g expression.g statement.g
CC = cc
GEN = /usr/em/util/LLgen/src/LLgen
GENOPTIONS = -d
LLGENOPTIONS = -d
PROFILE =
CFLAGS = $(PROFILE) $(INCLUDES) -DSTATIC=
LINTFLAGS = -DSTATIC= -DNORCSID
@ -30,7 +30,8 @@ GENCFILES= tokenfile.c \
GENGFILES= tokenfile.g
GENHFILES= errout.h\
idfsize.h numsize.h strsize.h target_sizes.h debug.h\
inputtype.h maxset.h ndir.h density.h
inputtype.h maxset.h ndir.h density.h\
def.h type.h Lpars.h node.h
#
GENFILES = $(GENGFILES) $(GENCFILES) $(GENHFILES)
all:
@ -39,7 +40,7 @@ all:
make main
LLfiles: $(LSRC)
$(GEN) $(GENOPTIONS) $(LSRC)
$(LLGEN) $(LLGENOPTIONS) $(LSRC)
@touch LLfiles
hfiles: Parameters make.hfiles
@ -47,7 +48,7 @@ hfiles: Parameters make.hfiles
touch hfiles
main: $(OBJ) Makefile
$(CC) $(LFLAGS) $(OBJ) /user1/erikb/em/lib/libem_mes.a /user1/erikb/em/lib/libeme.a $(LIBDIR)/libcomp.a $(LIBDIR)/malloc.o /user1/erikb/em/lib/libprint.a /user1/erikb/em/lib/libstr.a /user1/erikb/em/lib/libsystem.a -o main
$(CC) $(LFLAGS) $(OBJ) $(LIBDIR)/libem_mes.a $(LIBDIR)/libeme.a $(LIBDIR)/input.a $(LIBDIR)/assert.a $(LIBDIR)/alloc.a $(LIBDIR)/malloc.o $(LIBDIR)/libprint.a $(LIBDIR)/libstr.a $(LIBDIR)/libsystem.a -o main
size main
clean:

1
lang/m2/comp/casestat.C
View file

@ -8,6 +8,7 @@ static char *RcsId = "$Header$";
#include <em_label.h>
#include <em_arith.h>
#include <em_code.h>
#include <alloc.h>
#include <assert.h>

1
lang/m2/comp/code.c
View file

@ -11,6 +11,7 @@ static char *RcsId = "$Header$";
#include <em_arith.h>
#include <em_label.h>
#include <em_code.h>
#include <assert.h>
#include "type.h"

107
lang/m2/comp/cstoper.c
View file

@ -32,24 +32,28 @@ cstunary(expp)
/* The unary operation in "expp" is performed on the constant
expression below it, and the result restored in expp.
*/
arith o1 = expp->nd_right->nd_INT;
register arith o1 = expp->nd_right->nd_INT;
switch(expp->nd_symb) {
case '+':
break;
case '-':
o1 = -o1;
if (expp->nd_type->tp_fund == T_INTORCARD) {
expp->nd_type = int_type;
}
break;
case NOT:
case '~':
o1 = !o1;
break;
default:
crash("(cstunary)");
}
expp->nd_class = Value;
expp->nd_token = expp->nd_right->nd_token;
expp->nd_INT = o1;
@ -65,8 +69,8 @@ cstbin(expp)
expressions below it, and the result restored in
expp.
*/
arith o1 = expp->nd_left->nd_INT;
arith o2 = expp->nd_right->nd_INT;
register arith o1 = expp->nd_left->nd_INT;
register arith o2 = expp->nd_right->nd_INT;
int uns = expp->nd_type != int_type;
assert(expp->nd_class == Oper);
@ -158,15 +162,12 @@ cstbin(expp)
break;
case '<':
if (uns) {
o1 = (o1 & mach_long_sign ?
(o2 & mach_long_sign ? o1 < o2 : 0) :
(o2 & mach_long_sign ? 1 : o1 < o2)
);
{ arith tmp = o1;
o1 = o2;
o2 = tmp;
}
else
o1 = (o1 < o2);
break;
/* Fall through */
case '>':
if (uns) {
@ -178,16 +179,15 @@ cstbin(expp)
else
o1 = (o1 > o2);
break;
case LESSEQUAL:
if (uns) {
o1 = (o1 & mach_long_sign ?
(o2 & mach_long_sign ? o1 <= o2 : 0) :
(o2 & mach_long_sign ? 1 : o1 <= o2)
);
{ arith tmp = o1;
o1 = o2;
o2 = tmp;
}
else
o1 = (o1 <= o2);
break;
/* Fall through */
case GREATEREQUAL:
if (uns) {
o1 = (o1 & mach_long_sign ?
@ -198,22 +198,28 @@ cstbin(expp)
else
o1 = (o1 >= o2);
break;
case '=':
o1 = (o1 == o2);
break;
case '#':
o1 = (o1 != o2);
break;
case AND:
case '&':
o1 = (o1 && o2);
break;
case OR:
o1 = (o1 || o2);
break;
default:
crash("(cstbin)");
}
expp->nd_class = Value;
expp->nd_token = expp->nd_right->nd_token;
if (expp->nd_type == bool_type) expp->nd_symb = INTEGER;
@ -227,7 +233,7 @@ cstbin(expp)
cstset(expp)
register struct node *expp;
{
register arith *set1 = 0, *set2;
register arith *set1, *set2;
arith *resultset = 0;
register int setsize, j;
@ -253,6 +259,8 @@ cstset(expp)
expp->nd_left->nd_set = 0;
switch(expp->nd_symb) {
case '+':
/* Set union
*/
if (!set1) {
resultset = set2;
expp->nd_right->nd_set = 0;
@ -262,11 +270,15 @@ cstset(expp)
*set1++ |= *set2++;
}
break;
case '-':
/* Set difference
*/
if (!set1 || !set2) {
/* The set from which something is substracted
is already empty, or the set that is
substracted is empty
substracted is empty. In either case, the
result set is set1.
*/
break;
}
@ -274,34 +286,50 @@ cstset(expp)
*set1++ &= ~*set2++;
}
break;
case '*':
if (!set1) break;
/* Set intersection
*/
if (!set1) {
/* set1 is empty, and so is the result set
*/
break;
}
if (!set2) {
/* set 2 is empty, so the result set must be
empty too.
*/
resultset = set2;
expp->nd_right->nd_set = 0;
break;
}
for (j = 0; j < setsize; j++) {
*set1++ &= *set2++;
}
break;
case '/':
/* Symmetric set difference
*/
if (!set1) {
resultset = set2;
expp->nd_right->nd_set = 0;
break;
}
if (set2) for (j = 0; j < setsize; j++) {
*set1++ ^= *set2++;
if (set2) {
for (j = 0; j < setsize; j++) {
*set1++ ^= *set2++;
}
}
break;
case GREATEREQUAL:
case LESSEQUAL:
case '=':
case '#':
/* Clumsy, but who cares? Nobody writes these things! */
expp->nd_left->nd_set = set1;
/* Constant set comparisons
*/
expp->nd_left->nd_set = set1; /* may be disposed of */
for (j = 0; j < setsize; j++) {
switch(expp->nd_symb) {
case GREATEREQUAL:
@ -371,11 +399,13 @@ cstcall(expp, call)
register struct node *expr = 0;
assert(expp->nd_class == Call);
if (expp->nd_right) {
expr = expp->nd_right->nd_left;
expp->nd_right->nd_left = 0;
FreeNode(expp->nd_right);
}
expp->nd_class = Value;
expp->nd_symb = INTEGER;
switch(call) {
@ -384,6 +414,7 @@ cstcall(expp, call)
else expp->nd_INT = expr->nd_INT;
CutSize(expp);
break;
case S_CAP:
if (expr->nd_INT >= 'a' && expr->nd_INT <= 'z') {
expp->nd_INT = expr->nd_INT + ('A' - 'a');
@ -391,10 +422,12 @@ cstcall(expp, call)
else expp->nd_INT = expr->nd_INT;
CutSize(expp);
break;
case S_CHR:
expp->nd_INT = expr->nd_INT;
CutSize(expp);
break;
case S_MAX:
if (expp->nd_type == int_type) {
expp->nd_INT = max_int;
@ -410,6 +443,7 @@ cstcall(expp, call)
}
else expp->nd_INT = expp->nd_type->enm_ncst - 1;
break;
case S_MIN:
if (expp->nd_type == int_type) {
expp->nd_INT = (-max_int) - 1;
@ -422,16 +456,20 @@ cstcall(expp, call)
}
else expp->nd_INT = 0;
break;
case S_ODD:
expp->nd_INT = (expr->nd_INT & 1);
break;
case S_ORD:
expp->nd_INT = expr->nd_INT;
CutSize(expp);
break;
case S_SIZE:
expp->nd_INT = WA(expr->nd_type->tp_size) / word_size;
break;
case S_VAL:
expp->nd_INT = expr->nd_INT;
if ( /* Check overflow of subranges or enumerations */
@ -451,6 +489,7 @@ cstcall(expp, call)
) node_warning(expp,"overflow in constant expression");
else CutSize(expp);
break;
default:
crash("(cstcall)");
}
@ -465,8 +504,8 @@ CutSize(expr)
/* The constant value of the expression expr is made to
conform to the size of the type of the expression.
*/
arith o1 = expr->nd_INT;
struct type *tp = BaseType(expr->nd_type);
register arith o1 = expr->nd_INT;
register struct type *tp = BaseType(expr->nd_type);
int uns;
int size = tp->tp_size;
@ -476,8 +515,8 @@ CutSize(expr)
if (o1 & ~full_mask[size]) {
node_warning(expr,
"overflow in constant expression");
o1 &= full_mask[size];
}
o1 &= full_mask[size];
}
else {
int nbits = (int) (mach_long_size - size) * 8;
@ -485,17 +524,17 @@ CutSize(expr)
if (remainder != 0 && remainder != ~full_mask[size]) {
node_warning(expr, "overflow in constant expression");
o1 <<= nbits;
o1 >>= nbits;
}
o1 <<= nbits;
o1 >>= nbits;
}
expr->nd_INT = o1;
}
InitCst()
{
int i = 0;
arith bt = (arith)0;
register int i = 0;
register arith bt = (arith)0;
while (!(bt < 0)) {
bt = (bt << 8) + 0377, i++;

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

@ -33,21 +33,20 @@ ProcedureDeclaration
register struct def *df;
struct def *df1;
} :
{ proclevel++; }
ProcedureHeading(&df1, D_PROCEDURE)
{
CurrentScope->sc_definedby = df = df1;
df->prc_vis = CurrVis;
{ ++proclevel;
return_occurred = 0;
}
ProcedureHeading(&df1, D_PROCEDURE)
{ CurrentScope->sc_definedby = df = df1;
df->prc_vis = CurrVis;
}
';' block(&(df->prc_body)) IDENT
{
match_id(dot.TOK_IDF, df->df_idf);
{ match_id(dot.TOK_IDF, df->df_idf);
close_scope(SC_CHKFORW|SC_REVERSE);
if (! return_occurred && ResultType(df->df_type)) {
error("function procedure does not return a value", df->df_idf->id_text);
error("function procedure %s does not return a value", df->df_idf->id_text);
}
proclevel--;
--proclevel;
}
;
@ -56,22 +55,17 @@ ProcedureHeading(struct def **pdf; int type;)
struct paramlist *params = 0;
struct type *tp = 0;
register struct def *df;
struct def *DeclProc();
arith NBytesParams;
} :
PROCEDURE IDENT
{
df = DeclProc(type);
if (proclevel > 1) {
/* Room for static link
*/
{ df = DeclProc(type);
if (proclevel > 1) { /* need room for static link */
NBytesParams = pointer_size;
}
else NBytesParams = 0;
}
FormalParameters(&params, &tp, &NBytesParams)?
{
tp = construct_type(T_PROCEDURE, tp);
{ tp = construct_type(T_PROCEDURE, tp);
tp->prc_params = params;
tp->prc_nbpar = NBytesParams;
if (df->df_type) {
@ -85,9 +79,6 @@ error("inconsistent procedure declaration for \"%s\"", df->df_idf->id_text);
}
df->df_type = tp;
*pdf = df;
if (type == D_PROCHEAD) close_scope(0);
}
;
@ -115,7 +106,7 @@ declaration:
;
FormalParameters(struct paramlist **pr;
struct type **tp;
struct type **ptp;
arith *parmaddr;)
{
struct def *df;
@ -128,9 +119,7 @@ FormalParameters(struct paramlist **pr;
]*
]?
')'
[ ':' qualident(D_ISTYPE, &df, "type", (struct node **) 0)
{ *tp = df->df_type;
}
[ ':' qualtype(ptp)
]?
;
@ -138,13 +127,10 @@ FPSection(struct paramlist **ppr; arith *parmaddr;)
{
struct node *FPList;
struct type *tp;
int VARp = D_VALPAR;
int VARp;
struct paramlist *p = 0;
} :
[
VAR { VARp = D_VARPAR; }
]?
IdentList(&FPList) ':' FormalType(&p, 0)
var(&VARp) IdentList(&FPList) ':' FormalType(&p, 0)
{ EnterParamList(ppr, FPList, p->par_def->df_type,
VARp, parmaddr);
free_def(p->par_def);
@ -154,25 +140,24 @@ FPSection(struct paramlist **ppr; arith *parmaddr;)
FormalType(struct paramlist **ppr; int VARp;)
{
struct def *df1;
register struct def *df;
int ARRAYflag;
register struct type *tp;
struct type *tp1;
register struct paramlist *p = new_paramlist();
extern arith ArrayElSize();
} :
[ ARRAY OF { ARRAYflag = 1; }
| { ARRAYflag = 0; }
]
qualident(D_ISTYPE, &df1, "type", (struct node **) 0)
{ df = df1;
if (ARRAYflag) {
qualtype(&tp1)
{ if (ARRAYflag) {
tp = construct_type(T_ARRAY, NULLTYPE);
tp->arr_elem = df->df_type;
tp->arr_elsize = ArrayElSize(df->df_type);
tp->arr_elem = tp1;
tp->arr_elsize = ArrayElSize(tp1);
tp->tp_align = lcm(word_align, pointer_align);
}
else tp = df->df_type;
else tp = tp1;
p->next = *ppr;
*ppr = p;
p->par_def = df = new_def();
@ -186,23 +171,19 @@ TypeDeclaration
register struct def *df;
struct type *tp;
}:
IDENT { df = lookup(dot.TOK_IDF, CurrentScope);
if (!df) df = define(dot.TOK_IDF,CurrentScope,D_TYPE);
}
IDENT { df = define(dot.TOK_IDF,CurrentScope,D_TYPE); }
'=' type(&tp)
{
if (df->df_kind == D_HIDDEN) {
{ if (df->df_type && df->df_type->tp_fund == T_HIDDEN) {
if (tp->tp_fund != T_POINTER) {
error("opaque type \"%s\" is not a pointer type", df->df_idf->id_text);
}
df->df_kind = D_TYPE;
/* Careful now ... we might have declarations
referring to the hidden type.
*/
*(df->df_type) = *tp;
free_type(tp);
}
else {
df->df_type = tp;
df->df_kind = D_TYPE;
}
else df->df_type = tp;
}
;
@ -222,20 +203,17 @@ type(struct type **ptp;):
SimpleType(struct type **ptp;)
{
struct def *df;
struct type *tp;
} :
qualident(D_ISTYPE, &df, "type", (struct node **) 0)
qualtype(ptp)
[
/* nothing */
{ *ptp = df->df_type; }
|
SubrangeType(ptp)
SubrangeType(&tp)
/* The subrange type is given a base type by the
qualident (this is new modula-2).
*/
{
chk_basesubrange(*ptp, df->df_type);
}
{ chk_basesubrange(tp, *ptp); }
]
|
enumeration(ptp)
@ -249,8 +227,7 @@ enumeration(struct type **ptp;)
register struct type *tp;
} :
'(' IdentList(&EnumList) ')'
{
*ptp = tp = standard_type(T_ENUMERATION, 1, (arith) 1);
{ *ptp = tp = standard_type(T_ENUMERATION, 1, (arith) 1);
EnterEnumList(EnumList, tp);
if (tp->enm_ncst > 256) { /* ??? is this reasonable ??? */
error("Too many enumeration literals");
@ -262,9 +239,7 @@ IdentList(struct node **p;)
{
register struct node *q;
} :
IDENT { q = MkLeaf(Value, &dot);
*p = q;
}
IDENT { *p = q = MkLeaf(Value, &dot); }
[
',' IDENT
{ q->next = MkLeaf(Value, &dot);
@ -285,8 +260,7 @@ SubrangeType(struct type **ptp;)
'[' ConstExpression(&nd1)
UPTO ConstExpression(&nd2)
']'
{ *ptp = subr_type(nd1, nd2);
}
{ *ptp = subr_type(nd1, nd2); }
;
ArrayType(struct type **ptp;)
@ -295,9 +269,7 @@ ArrayType(struct type **ptp;)
register struct type *tp2;
} :
ARRAY SimpleType(&tp)
{
*ptp = tp2 = construct_type(T_ARRAY, tp);
}
{ *ptp = tp2 = construct_type(T_ARRAY, tp); }
[
',' SimpleType(&tp)
{ tp2->arr_elem = construct_type(T_ARRAY, tp);
@ -311,20 +283,19 @@ ArrayType(struct type **ptp;)
RecordType(struct type **ptp;)
{
struct scope *scope;
register struct scope *scope;
arith count;
int xalign = struct_align;
}
:
RECORD
{ open_scope(OPENSCOPE);
scope = CurrentScope;
close_scope(0);
count = 0;
}
{ open_scope(OPENSCOPE);
scope = CurrentScope;
close_scope(0);
count = 0;
}
FieldListSequence(scope, &count, &xalign)
{
*ptp = standard_type(T_RECORD, xalign, WA(count));
{ *ptp = standard_type(T_RECORD, xalign, WA(count));
(*ptp)->rec_scope = scope;
}
END
@ -340,8 +311,8 @@ FieldListSequence(struct scope *scope; arith *cnt; int *palign;):
FieldList(struct scope *scope; arith *cnt; int *palign;)
{
struct node *FldList;
struct idf *id;
struct def *df;
register struct idf *id = gen_anon_idf();
register struct def *df;
struct type *tp;
struct node *nd;
arith tcnt, max;
@ -355,41 +326,37 @@ FieldList(struct scope *scope; arith *cnt; int *palign;)
CASE
/* Also accept old fashioned Modula-2 syntax, but give a warning
*/
[ qualident(0, &df, (char *) 0, &nd)
[ /* This is good, in both kinds of Modula-2, if
[ qualident(0, (struct def **) 0, (char *) 0, &nd)
[ ':' qualtype(&tp)
/* This is correct, in both kinds of Modula-2, if
the first qualident is a single identifier.
*/
{ if (nd->nd_class != Name) {
error("illegal variant tag");
id = gen_anon_idf();
}
else id = nd->nd_IDF;
}
':' qualident(D_ISTYPE, &df, "type", (struct node **) 0)
{ if (nd->nd_class != Name) {
error("illegal variant tag");
}
else id = nd->nd_IDF;
}
|
/* Old fashioned! the first qualident now represents
the type
*/
{ warning("Old fashioned Modula-2 syntax!");
id = gen_anon_idf();
df = ill_df;
if (chk_designator(nd) &&
(nd->nd_class != Def ||
!(nd->nd_def->df_kind &
(D_ERROR|D_ISTYPE)))) {
!(nd->nd_def->df_kind&(D_ERROR|D_ISTYPE)) ||
!nd->nd_def->df_type)) {
node_error(nd, "type expected");
tp = error_type;
}
else df = nd->nd_def;
else tp = nd->nd_def->df_type;
FreeNode(nd);
}
]
|
/* Aha, third edition? */
':' qualident(D_ISTYPE, &df, "type", (struct node **) 0)
{ id = gen_anon_idf(); }
/* Aha, third edition. Well done! */
':' qualtype(&tp)
]
{ tp = df->df_type;
if (!(tp->tp_fund & T_DISCRETE)) {
{ if (!(tp->tp_fund & T_DISCRETE)) {
error("Illegal type in variant");
}
df = define(id, scope, D_FIELD);
@ -464,12 +431,9 @@ node_error(nd1,"type incompatibility in case label");
SetType(struct type **ptp;)
{
struct type *tp;
} :
SET OF SimpleType(&tp)
{
*ptp = set_type(tp);
}
SET OF SimpleType(ptp)
{ *ptp = set_type(*ptp); }
;
/* In a pointer type definition, the type pointed at does not
@ -478,46 +442,48 @@ SetType(struct type **ptp;)
*/
PointerType(struct type **ptp;)
{
struct type *tp;
struct def *df;
struct node *nd;
register struct def *df;
register struct node *nd;
} :
POINTER TO
[ %if ( (df = lookup(dot.TOK_IDF, CurrentScope)))
{ *ptp = construct_type(T_POINTER, NULLTYPE); }
[ %if ( lookup(dot.TOK_IDF, CurrentScope))
/* Either a Module or a Type, but in both cases defined
in this scope, so this is the correct identification
*/
qualident(D_ISTYPE, &df, "type", (struct node **) 0)
{
if (!df->df_type) {
error("type \"%s\" not declared",
df->df_idf->id_text);
tp = error_type;
}
else tp = df->df_type;
}
qualtype(&((*ptp)->next))
| %if ( nd = new_node(), nd->nd_token = dot,
df = lookfor(nd, CurrVis, 0), free_node(nd),
df->df_kind == D_MODULE)
type(&tp)
type(&((*ptp)->next))
|
IDENT
{ tp = NULLTYPE; }
IDENT { Forward(&dot, &((*ptp)->next)); }
]
{
*ptp = construct_type(T_POINTER, tp);
if (!tp) Forward(&dot, &((*ptp)->next));
}
;
qualtype(struct type **ptp;)
{
struct def *df;
} :
qualident(D_ISTYPE, &df, "type", (struct node **) 0)
{ if (!df->df_type) {
error("type \"%s\" not declared", df->df_idf->id_text);
*ptp = error_type;
}
else *ptp = df->df_type;
}
;
ProcedureType(struct type **ptp;)
{
struct paramlist *pr = 0;
struct type *tp = 0;
register struct type *tp;
} :
PROCEDURE FormalTypeList(&pr, &tp)?
{ *ptp = construct_type(T_PROCEDURE, tp);
(*ptp)->prc_params = pr;
{ *ptp = 0; }
PROCEDURE FormalTypeList(&pr, ptp)?
{ *ptp = tp = construct_type(T_PROCEDURE, *ptp);
tp->prc_params = pr;
}
;
@ -528,34 +494,30 @@ FormalTypeList(struct paramlist **ppr; struct type **ptp;)
} :
'(' { *ppr = 0; }
[
[ VAR { VARp = D_VARPAR; }
| { VARp = D_VALPAR; }
]
FormalType(ppr, VARp)
var(&VARp) FormalType(ppr, VARp)
[
','
[ VAR {VARp = D_VARPAR; }
| {VARp = D_VALPAR; }
]
FormalType(ppr, VARp)
',' var(&VARp) FormalType(ppr, VARp)
]*
]?
')'
[ ':' qualident(D_TYPE, &df, "type", (struct node **) 0)
{ *ptp = df->df_type; }
[ ':' qualtype(ptp)
]?
;
var(int *VARp;):
VAR { *VARp = D_VARPAR; }
|
/* empty */ { *VARp = D_VALPAR; }
;
ConstantDeclaration
{
struct def *df;
struct idf *id;
struct node *nd;
}:
IDENT { id = dot.TOK_IDF; }
'=' ConstExpression(&nd){ df = define(id, CurrentScope, D_CONST);
df->con_const = nd;
}
IDENT { id = dot.TOK_IDF; }
'=' ConstExpression(&nd)
{ define(id,CurrentScope,D_CONST)->con_const = nd; }
;
VariableDeclaration

1
lang/m2/comp/def.H
View file

@ -119,6 +119,7 @@ extern struct def
*define(),
*DefineLocalModule(),
*MkDef(),
*DeclProc(),
*ill_df;
extern struct def

10
lang/m2/comp/def.c
View file

@ -232,16 +232,6 @@ DeclProc(type)
return df;
}
InitProc(nd, df)
struct node *nd;
struct def *df;
{
/* Create an initialization procedure for a module.
*/
df->mod_body = nd;
/* Keep it this way, or really create a procedure out of it??? */
}
AddModule(id)
struct idf *id;
{

1
lang/m2/comp/desig.c
View file

@ -15,6 +15,7 @@ static char *RcsId = "$Header$";
#include <em_arith.h>
#include <em_label.h>
#include <em_code.h>
#include <assert.h>
#include "type.h"

1
lang/m2/comp/enter.c
View file

@ -9,6 +9,7 @@ static char *RcsId = "$Header$";
#include <alloc.h>
#include <em_arith.h>
#include <em_label.h>
#include <em_code.h>
#include <assert.h>
#include "idf.h"

21
lang/m2/comp/expression.g
View file

@ -78,17 +78,16 @@ selector(struct node **pnd;):
ExpList(struct node **pnd;)
{
struct node **nd;
register struct node *nd;
} :
expression(pnd) { *pnd = MkNode(Link, *pnd, NULLNODE, &dot);
expression(pnd) { *pnd = nd = MkNode(Link,*pnd,NULLNODE,&dot);
(*pnd)->nd_symb = ',';
nd = &((*pnd)->nd_right);
}
[
',' { *nd = MkLeaf(Link, &dot);
',' { nd->nd_right = MkLeaf(Link, &dot);
nd = nd->nd_right;
}
expression(&(*nd)->nd_left)
{ nd = &((*nd)->nd_right); }
expression(&(nd->nd_left))
]*
;
@ -169,7 +168,7 @@ MulOperator:
;
*/
factor(struct node **p;)
factor(register struct node **p;)
{
struct def *df;
struct node *nd;
@ -190,8 +189,7 @@ factor(struct node **p;)
| %default
number(p)
|
STRING {
*p = MkLeaf(Value, &dot);
STRING { *p = MkLeaf(Value, &dot);
(*p)->nd_type = toktype;
}
|
@ -205,8 +203,7 @@ bare_set(struct node **pnd;)
{
register struct node *nd;
} :
'{' {
dot.tk_symb = SET;
'{' { dot.tk_symb = SET;
*pnd = nd = MkLeaf(Xset, &dot);
nd->nd_type = bitset_type;
}
@ -255,7 +252,7 @@ designator_tail(struct node **pnd;):
]*
;
visible_designator_tail(struct node **pnd;):
visible_designator_tail(register struct node **pnd;):
'[' { *pnd = MkNode(Arrsel, *pnd, NULLNODE, &dot); }
expression(&((*pnd)->nd_right))
[

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

@ -26,7 +26,7 @@ static char *RcsId = "$Header$";
int state; /* either IMPLEMENTATION or PROGRAM */
char options[128];
int DefinitionModule;
int SYSTEMModule = 0;
int SYSTEMModule;
char *ProgName;
char *DEFPATH[NDIRS+1];
struct def *Defined;
@ -34,7 +34,7 @@ extern int err_occurred;
extern int fp_used; /* set if floating point used */
main(argc, argv)
char *argv[];
register char **argv;
{
register int Nargc = 1;
register char **Nargv = &argv[0];
@ -84,9 +84,7 @@ Compile(src, dst)
open_scope(CLOSEDSCOPE);
GlobalScope = CurrentScope;
C_init(word_size, pointer_size);
if (! C_open(dst)) {
fatal("Could not open output file");
}
if (! C_open(dst)) fatal("Could not open output file");
C_magic();
C_ms_emx(word_size, pointer_size);
CompUnit();
@ -95,9 +93,7 @@ Compile(src, dst)
if (!err_occurred) {
C_exp(Defined->mod_vis->sc_scope->sc_name);
WalkModule(Defined);
if (fp_used) {
C_ms_flt();
}
if (fp_used) C_ms_flt();
}
C_close();
#ifdef DEBUG

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

@ -41,9 +41,8 @@ static char *RcsId = "$Header$";
ModuleDeclaration
{
struct idf *id;
struct def *df;
struct node *nd;
struct idf *id; /* save module identifier */
register struct def *df;
struct node *exportlist = 0;
int qualified;
} :
@ -54,9 +53,8 @@ ModuleDeclaration
';'
import(1)*
export(&qualified, &exportlist)?
block(&nd)
IDENT { InitProc(nd, df);
if (exportlist) {
block(&(df->mod_body))
IDENT { if (exportlist) {
EnterExportList(exportlist, qualified);
}
close_scope(SC_CHKFORW|SC_CHKPROC|SC_REVERSE);
@ -93,11 +91,13 @@ export(int *QUALflag; struct node **ExportList;)
import(int local;)
{
struct node *ImportList;
struct node *id = 0;
register struct node *id;
} :
[ FROM
IDENT { id = MkLeaf(Value, &dot); }
]?
|
{ id = 0; }
]
IMPORT IdentList(&ImportList) ';'
/*
When parsing a global module, this is the place where we must
@ -113,8 +113,8 @@ import(int local;)
DefinitionModule
{
register struct def *df;
struct idf *id;
struct node *exportlist = 0;
struct idf *id; /* save module identifier */
struct node *exportlist;
int dummy;
} :
DEFINITION
@ -130,19 +130,20 @@ DefinitionModule
}
';'
import(0)*
export(&dummy, &exportlist)?
/* New Modula-2 does not have export lists in definition modules.
For the time being, we ignore export lists here, and a
warning is issued.
*/
{ if (exportlist) {
[
export(&dummy, &exportlist)
/* New Modula-2 does not have export lists in definition
modules. Issue a warning.
*/
{
node_warning(exportlist, "export list in definition module ignored");
FreeNode(exportlist);
}
}
|
/* empty */
]
definition* END IDENT
{
df = CurrentScope->sc_def;
{ df = CurrentScope->sc_def;
while (df) {
/* Make all definitions "QUALIFIED EXPORT" */
df->df_flags |= D_QEXPORTED;
@ -157,7 +158,8 @@ node_warning(exportlist, "export list in definition module ignored");
definition
{
struct def *df;
register struct def *df;
struct def *dummy;
} :
CONST [ ConstantDeclaration Semicolon ]*
|
@ -179,13 +181,17 @@ definition
|
VAR [ VariableDeclaration Semicolon ]*
|
ProcedureHeading(&df, D_PROCHEAD) Semicolon
ProcedureHeading(&dummy, D_PROCHEAD)
{ close_scope(0); }
Semicolon
;
/* The next nonterminal is used to relax the grammar a little.
*/
Semicolon:
';'
|
{ warning("; expected"); }
/* empty */ { warning("; expected"); }
;
ProgramModule
@ -193,30 +199,26 @@ ProgramModule
struct idf *id;
struct def *GetDefinitionModule();
register struct def *df;
struct node *nd;
} :
MODULE
IDENT { id = dot.TOK_IDF;
if (state == IMPLEMENTATION) {
df = GetDefinitionModule(id);
CurrVis = df->mod_vis;
CurrentScope = CurrVis->sc_scope;
RemoveImports(&(CurrentScope->sc_def));
}
else {
df = define(id, CurrentScope, D_MODULE);
Defined = df = define(id, CurrentScope, D_MODULE);
open_scope(CLOSEDSCOPE);
df->mod_vis = CurrVis;
CurrentScope->sc_name = "_M2M";
}
Defined = df;
CurrentScope->sc_definedby = df;
}
priority(&(df->mod_priority))?
';' import(0)*
block(&nd) IDENT
{ InitProc(nd, df);
close_scope(SC_CHKFORW|SC_CHKPROC|SC_REVERSE);
block(&(df->mod_body)) IDENT
{ close_scope(SC_CHKFORW|SC_CHKPROC|SC_REVERSE);
match_id(id, dot.TOK_IDF);
}
'.'
@ -228,7 +230,7 @@ Module:
[
IMPLEMENTATION { state = IMPLEMENTATION; }
|
{ state = PROGRAM; }
/* empty */ { state = PROGRAM; }
]
ProgramModule
;

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

@ -23,7 +23,6 @@ statement(register struct node **pnd;)
{
register struct node *nd;
} :
[
/*
* This part is not in the reference grammar. The reference grammar
* states : assignment | ProcedureCall | ...
@ -67,7 +66,6 @@ statement(register struct node **pnd;)
ReturnStatement(pnd)
|
/* empty */ { *pnd = 0; }
]
;
/*
@ -194,8 +192,7 @@ ForStatement(struct node **pnd;)
[
BY
ConstExpression(&dummy)
{
if (!(dummy->nd_type->tp_fund & T_INTORCARD)) {
{ if (!(dummy->nd_type->tp_fund & T_INTORCARD)) {
error("illegal type in BY clause");
}
nd->nd_INT = dummy->nd_INT;

9
lang/m2/comp/tmpvar.C
View file

@ -33,10 +33,17 @@ struct tmpvar {
static struct tmpvar *TmpInts, /* for integer temporaries */
*TmpPtrs; /* for pointer temporaries */
extern struct scope *ProcScope; /* scope of procedure in which the
static struct scope *ProcScope; /* scope of procedure in which the
temporaries are allocated
*/
TmpOpen(sc) struct scope *sc;
{
/* Initialize for temporaries in scope "sc".
*/
ProcScope = sc;
}
arith
NewInt()
{

1
lang/m2/comp/type.c
View file

@ -12,6 +12,7 @@ static char *RcsId = "$Header$";
#include <alloc.h>
#include <em_arith.h>
#include <em_label.h>
#include <em_code.h>
#include "def.h"
#include "type.h"

35
lang/m2/comp/walk.c
View file

@ -13,6 +13,7 @@ static char *RcsId = "$Header$";
#include <em_arith.h>
#include <em_label.h>
#include <em_reg.h>
#include <em_code.h>
#include <assert.h>
#include "def.h"
@ -36,7 +37,6 @@ label data_label;
static struct type *func_type;
struct withdesig *WithDesigs;
struct node *Modules;
struct scope *ProcScope;
STATIC
DoProfil()
@ -74,9 +74,9 @@ WalkModule(module)
First call initialization routines for modules defined within
this module.
*/
sc->sc_off = 0;
sc->sc_off = 0; /* no locals (yet) */
text_label = 1;
ProcScope = sc;
TmpOpen(sc); /* Initialize for temporaries */
C_pro_narg(sc->sc_name);
DoProfil();
if (module == Defined) {
@ -130,7 +130,7 @@ WalkProcedure(procedure)
proclevel++;
CurrVis = procedure->prc_vis;
ProcScope = sc = CurrentScope;
sc = CurrentScope;
/* Generate code for all local modules and procedures
*/
@ -140,6 +140,7 @@ WalkProcedure(procedure)
*/
C_pro_narg(sc->sc_name);
DoProfil();
TmpOpen(sc);
/* Generate calls to initialization routines of modules defined within
this procedure
@ -397,20 +398,16 @@ WalkStat(nd, lab)
wds.w_next = WithDesigs;
WithDesigs = &wds;
wds.w_scope = left->nd_type->rec_scope;
if (ds.dsg_kind != DSG_PFIXED) {
/* In this case, we use a temporary variable
*/
CodeAddress(&ds);
ds.dsg_kind = DSG_FIXED;
/* Create a designator structure for the
temporary.
*/
ds.dsg_offset = tmp = NewPtr();
ds.dsg_name = 0;
CodeStore(&ds, pointer_size);
ds.dsg_kind = DSG_PFIXED;
/* the record is indirectly available */
}
CodeAddress(&ds);
ds.dsg_kind = DSG_FIXED;
/* Create a designator structure for the
temporary.
*/
ds.dsg_offset = tmp = NewPtr();
ds.dsg_name = 0;
CodeStore(&ds, pointer_size);
ds.dsg_kind = DSG_PFIXED;
/* the record is indirectly available */
wds.w_desig = ds;
link.sc_scope = wds.w_scope;
link.next = CurrVis;
@ -418,7 +415,7 @@ WalkStat(nd, lab)
WalkNode(right, lab);
CurrVis = link.next;
WithDesigs = wds.w_next;
if (tmp) FreePtr(tmp);
FreePtr(tmp);
break;
}