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

Several bug fixes

Browse source
This commit is contained in:
ceriel 1986-11-05 14:33:00 +00:00
parent 97e027db33
commit 9291d87dab
26 changed files with 401 additions and 164 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -18,6 +18,7 @@
#include "type.h" #include "type.h"
#include "LLlex.h" #include "LLlex.h"
#include "const.h" #include "const.h"
#include "warning.h"
long str2long(); long str2long();
@ -29,6 +30,8 @@ int idfsize = IDFSIZE;
extern int cntlines; extern int cntlines;
#endif #endif
static int eofseen;
STATIC STATIC
SkipComment() SkipComment()
{ {
@ -104,6 +107,81 @@ GetString(upto)
return str; return str;
} }
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;
}
STATIC
linedirective() {
/* Read a line directive
*/
register int ch;
register int i = 0;
char buf[IDFSIZE + 2];
register char *c = buf;
do { /*
* Skip to next digit
* Do not skip newlines
*/
ch = getch();
if (class(ch) == STNL) {
LineNumber++;
error(s_error);
return;
}
} while (class(ch) != STNUM);
do {
i = i*10 + (ch - '0');
ch = getch();
} while (class(ch) == STNUM);
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,strlen(buf) + 1);
}
}
if (eofseen) {
error(s_error);
return;
}
LineNumber = i;
}
int int
LLlex() LLlex()
{ {
@ -113,7 +191,6 @@ LLlex()
register struct token *tk = ˙ register struct token *tk = ˙
char buf[(IDFSIZE > NUMSIZE ? IDFSIZE : NUMSIZE) + 2]; char buf[(IDFSIZE > NUMSIZE ? IDFSIZE : NUMSIZE) + 2];
register int ch, nch; register int ch, nch;
static int eofseen;
toktype = error_type; toktype = error_type;
@ -125,6 +202,7 @@ LLlex()
tk->tk_lineno = LineNumber; tk->tk_lineno = LineNumber;
again2:
if (eofseen) { if (eofseen) {
eofseen = 0; eofseen = 0;
ch = EOI; ch = EOI;
@ -132,8 +210,10 @@ LLlex()
else { else {
again: again:
LoadChar(ch); LoadChar(ch);
again1:
if ((ch & 0200) && ch != EOI) { if ((ch & 0200) && ch != EOI) {
fatal("non-ascii '\\%03o' read", ch & 0377); error("non-ascii '\\%03o' read", ch & 0377);
goto again;
} }
} }
@ -145,7 +225,10 @@ again:
cntlines++; cntlines++;
#endif #endif
tk->tk_lineno++; tk->tk_lineno++;
/* Fall Through */ LoadChar(ch);
if (ch != '#') goto again1;
linedirective();
goto again2;
case STSKIP: case STSKIP:
goto again; goto again;
@ -192,7 +275,7 @@ again:
return tk->tk_symb = LESSEQUAL; return tk->tk_symb = LESSEQUAL;
} }
if (nch == '>') { if (nch == '>') {
lexwarning("'<>' is old-fashioned; use '#'"); lexwarning(W_STRICT, "'<>' is old-fashioned; use '#'");
return tk->tk_symb = '#'; return tk->tk_symb = '#';
} }
break; break;
@ -331,7 +414,7 @@ again:
if (ch == 'C' && base == 8) { if (ch == 'C' && base == 8) {
toktype = char_type; toktype = char_type;
if (tk->TOK_INT<0 || tk->TOK_INT>255) { if (tk->TOK_INT<0 || tk->TOK_INT>255) {
lexwarning("Character constant out of range"); lexwarning(W_ORDINARY, "character constant out of range");
} }
} }
else if (tk->TOK_INT>=0 && else if (tk->TOK_INT>=0 &&

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

@ -21,15 +21,16 @@ extern int err_occurred;
LLmessage(tk) LLmessage(tk)
int tk; int tk;
{ {
if (tk) { if (tk > 0) {
/* if (tk != 0), it represents the token to be inserted. /* if (tk > 0), it represents the token to be inserted.
otherwize, the current token is deleted
*/ */
error("%s missing", symbol2str(tk)); error("%s missing", symbol2str(tk));
insert_token(tk); insert_token(tk);
} }
else else if (tk < 0) {
error("%s deleted", symbol2str(dot.tk_symb)); error("garbage at end of program");
}
else error("%s deleted", symbol2str(dot.tk_symb));
} }
insert_token(tk) insert_token(tk)

58
lang/m2/comp/Makefile
View file

@ -3,6 +3,7 @@ EMDIR = ../../..
MHDIR = $(EMDIR)/modules/h MHDIR = $(EMDIR)/modules/h
PKGDIR = $(EMDIR)/modules/pkg PKGDIR = $(EMDIR)/modules/pkg
LIBDIR = $(EMDIR)/modules/lib LIBDIR = $(EMDIR)/modules/lib
OBJECTCODE = $(LIBDIR)/libemk.a
LLGEN = $(EMDIR)/bin/LLgen LLGEN = $(EMDIR)/bin/LLgen
INCLUDES = -I$(MHDIR) -I$(EMDIR)/h -I$(PKGDIR) INCLUDES = -I$(MHDIR) -I$(EMDIR)/h -I$(PKGDIR)
@ -13,6 +14,7 @@ LLGENOPTIONS =
PROFILE = PROFILE =
CFLAGS = $(PROFILE) $(INCLUDES) -DSTATIC= CFLAGS = $(PROFILE) $(INCLUDES) -DSTATIC=
LINTFLAGS = -DSTATIC= -DNORCSID LINTFLAGS = -DSTATIC= -DNORCSID
MALLOC = $(LIBDIR)/dickmalloc.o
LFLAGS = $(PROFILE) LFLAGS = $(PROFILE)
LSRC = tokenfile.c program.c declar.c expression.c statement.c LSRC = tokenfile.c program.c declar.c expression.c statement.c
LOBJ = tokenfile.o program.o declar.o expression.o statement.o LOBJ = tokenfile.o program.o declar.o expression.o statement.o
@ -35,13 +37,13 @@ GENCFILES= tokenfile.c \
symbol2str.c char.c Lpars.c casestat.c tmpvar.c scope.c symbol2str.c char.c Lpars.c casestat.c tmpvar.c scope.c
GENGFILES= tokenfile.g GENGFILES= tokenfile.g
GENHFILES= errout.h\ GENHFILES= errout.h\
idfsize.h numsize.h strsize.h target_sizes.h debug.h\ idfsize.h numsize.h strsize.h target_sizes.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 def.h debugcst.h type.h Lpars.h node.h
HFILES= LLlex.h\ HFILES= LLlex.h\
chk_expr.h class.h const.h desig.h f_info.h idf.h\ chk_expr.h class.h const.h debug.h desig.h f_info.h idf.h\
input.h main.h misc.h scope.h standards.h tokenname.h\ input.h main.h misc.h scope.h standards.h tokenname.h\
walk.h $(GENHFILES) walk.h warning.h $(GENHFILES)
# #
GENFILES = $(GENGFILES) $(GENCFILES) $(GENHFILES) GENFILES = $(GENGFILES) $(GENCFILES) $(GENHFILES)
@ -67,7 +69,7 @@ clashes: $(SRC) $(HFILES)
# entry points not to be used directly # entry points not to be used directly
Cfiles: hfiles LLfiles $(GENCFILES) $(GENHFILES) Cfiles: hfiles LLfiles $(GENCFILES) $(GENHFILES) Makefile
echo $(SRC) $(HFILES) > Cfiles echo $(SRC) $(HFILES) > Cfiles
LLfiles: $(GFILES) LLfiles: $(GFILES)
@ -122,39 +124,39 @@ Xlint:
lint $(INCLUDES) $(LINTFLAGS) $(SRC) lint $(INCLUDES) $(LINTFLAGS) $(SRC)
../comp/main: $(OBJ) ../comp/Makefile ../comp/main: $(OBJ) ../comp/Makefile
$(CC) $(LFLAGS) $(OBJ) $(LIBDIR)/libem_mes.a $(LIBDIR)/libemk.a $(LIBDIR)/input.a $(LIBDIR)/assert.a $(LIBDIR)/alloc.a $(LIBDIR)/malloc.o $(LIBDIR)/libprint.a $(LIBDIR)/libstr.a $(LIBDIR)/libsystem.a -o ../comp/main $(CC) $(LFLAGS) $(OBJ) $(LIBDIR)/libem_mes.a $(OBJECTCODE) $(LIBDIR)/libinput.a $(LIBDIR)/libassert.a $(LIBDIR)/liballoc.a $(MALLOC) $(LIBDIR)/libprint.a $(LIBDIR)/libstring.a $(LIBDIR)/libsystem.a -o ../comp/main
size ../comp/main size ../comp/main
#AUTOAUTOAUTOAUTOAUTOAUTOAUTOAUTO #AUTOAUTOAUTOAUTOAUTOAUTOAUTOAUTO
LLlex.o: LLlex.h Lpars.h class.h const.h debug.h f_info.h idf.h idfsize.h input.h inputtype.h numsize.h strsize.h type.h LLlex.o: LLlex.h Lpars.h class.h const.h debug.h debugcst.h f_info.h idf.h idfsize.h input.h inputtype.h numsize.h strsize.h type.h warning.h
LLmessage.o: LLlex.h Lpars.h idf.h LLmessage.o: LLlex.h Lpars.h idf.h
char.o: class.h char.o: class.h
error.o: LLlex.h debug.h errout.h f_info.h input.h inputtype.h main.h node.h error.o: LLlex.h debug.h debugcst.h errout.h f_info.h input.h inputtype.h main.h node.h warning.h
main.o: LLlex.h Lpars.h debug.h def.h f_info.h idf.h input.h inputtype.h ndir.h node.h scope.h standards.h tokenname.h type.h main.o: LLlex.h Lpars.h debug.h debugcst.h def.h f_info.h idf.h input.h inputtype.h ndir.h node.h scope.h standards.h tokenname.h type.h warning.h
symbol2str.o: Lpars.h symbol2str.o: Lpars.h
tokenname.o: Lpars.h idf.h tokenname.h tokenname.o: Lpars.h idf.h tokenname.h
idf.o: idf.h idf.o: idf.h
input.o: def.h f_info.h idf.h input.h inputtype.h scope.h input.o: def.h f_info.h idf.h input.h inputtype.h scope.h
type.o: LLlex.h const.h debug.h def.h idf.h maxset.h node.h scope.h target_sizes.h type.h walk.h type.o: LLlex.h const.h debug.h debugcst.h def.h idf.h maxset.h node.h scope.h target_sizes.h type.h walk.h
def.o: LLlex.h Lpars.h debug.h def.h idf.h main.h node.h scope.h type.h def.o: LLlex.h Lpars.h debug.h debugcst.h def.h idf.h main.h node.h scope.h type.h
scope.o: LLlex.h debug.h def.h idf.h node.h scope.h type.h scope.o: LLlex.h debug.h debugcst.h def.h idf.h node.h scope.h type.h
misc.o: LLlex.h f_info.h idf.h misc.h node.h misc.o: LLlex.h f_info.h idf.h misc.h node.h
enter.o: LLlex.h debug.h def.h idf.h main.h node.h scope.h type.h enter.o: LLlex.h debug.h debugcst.h def.h idf.h main.h node.h scope.h type.h
defmodule.o: LLlex.h Lpars.h debug.h def.h f_info.h idf.h input.h inputtype.h main.h node.h scope.h defmodule.o: LLlex.h Lpars.h debug.h debugcst.h def.h f_info.h idf.h input.h inputtype.h main.h node.h scope.h type.h
typequiv.o: LLlex.h debug.h def.h node.h type.h typequiv.o: LLlex.h debug.h debugcst.h def.h node.h type.h warning.h
node.o: LLlex.h debug.h def.h node.h type.h node.o: LLlex.h debug.h debugcst.h def.h node.h type.h
cstoper.o: LLlex.h Lpars.h debug.h idf.h node.h standards.h target_sizes.h type.h cstoper.o: LLlex.h Lpars.h debug.h debugcst.h idf.h node.h standards.h target_sizes.h type.h warning.h
chk_expr.o: LLlex.h Lpars.h chk_expr.h const.h debug.h def.h idf.h misc.h node.h scope.h standards.h type.h chk_expr.o: LLlex.h Lpars.h chk_expr.h const.h debug.h debugcst.h def.h idf.h misc.h node.h scope.h standards.h type.h warning.h
options.o: idfsize.h main.h ndir.h type.h options.o: idfsize.h main.h ndir.h type.h warning.h
walk.o: LLlex.h Lpars.h chk_expr.h debug.h def.h desig.h f_info.h idf.h main.h node.h scope.h type.h walk.h walk.o: LLlex.h Lpars.h chk_expr.h debug.h debugcst.h def.h desig.h f_info.h idf.h main.h node.h scope.h type.h walk.h warning.h
casestat.o: LLlex.h Lpars.h debug.h density.h desig.h node.h type.h walk.h casestat.o: LLlex.h Lpars.h debug.h debugcst.h density.h desig.h node.h type.h walk.h
desig.o: LLlex.h debug.h def.h desig.h node.h scope.h type.h desig.o: LLlex.h debug.h debugcst.h def.h desig.h node.h scope.h type.h
code.o: LLlex.h Lpars.h debug.h def.h desig.h node.h scope.h standards.h type.h walk.h code.o: LLlex.h Lpars.h debug.h debugcst.h def.h desig.h node.h scope.h standards.h type.h walk.h
tmpvar.o: debug.h def.h main.h scope.h type.h tmpvar.o: debug.h debugcst.h def.h main.h scope.h type.h
lookup.o: LLlex.h debug.h def.h idf.h misc.h node.h scope.h type.h lookup.o: LLlex.h debug.h debugcst.h def.h idf.h misc.h node.h scope.h type.h
tokenfile.o: Lpars.h tokenfile.o: Lpars.h
program.o: LLlex.h Lpars.h debug.h def.h f_info.h idf.h main.h node.h scope.h type.h program.o: LLlex.h Lpars.h debug.h debugcst.h def.h f_info.h idf.h main.h node.h scope.h type.h warning.h
declar.o: LLlex.h Lpars.h chk_expr.h debug.h def.h idf.h main.h misc.h node.h scope.h type.h declar.o: LLlex.h Lpars.h chk_expr.h debug.h debugcst.h def.h idf.h main.h misc.h node.h scope.h type.h warning.h
expression.o: LLlex.h Lpars.h chk_expr.h const.h debug.h def.h idf.h node.h type.h expression.o: LLlex.h Lpars.h chk_expr.h const.h debug.h debugcst.h def.h idf.h node.h type.h warning.h
statement.o: LLlex.h Lpars.h def.h idf.h node.h scope.h type.h statement.o: LLlex.h Lpars.h def.h idf.h node.h scope.h type.h
Lpars.o: Lpars.h Lpars.o: Lpars.h

8
lang/m2/comp/Parameters
View file

@ -45,14 +45,8 @@
#define AL_UNION 1 #define AL_UNION 1
!File: debug.h !File: debugcst.h
#define DEBUG 1 /* perform various self-tests */ #define DEBUG 1 /* perform various self-tests */
extern char options[];
#ifdef DEBUG
#define DO_DEBUG(y, x) ((y) && (x))
#else
#define DO_DEBUG(y, x)
#endif DEBUG
!File: inputtype.h !File: inputtype.h
#define INP_READ_IN_ONE 1 /* read input file in one */ #define INP_READ_IN_ONE 1 /* read input file in one */

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

@ -1 +1 @@
char Version[] = "Version 0.6"; char Version[] = "Version 0.7";

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

@ -69,6 +69,7 @@ CaseCode(nd, exitlabel)
register struct case_entry *ce; register struct case_entry *ce;
register arith val; register arith val;
label CaseDescrLab; label CaseDescrLab;
int casecnt = 0;
assert(pnode->nd_class == Stat && pnode->nd_symb == CASE); assert(pnode->nd_class == Stat && pnode->nd_symb == CASE);
@ -85,6 +86,7 @@ CaseCode(nd, exitlabel)
/* non-empty case /* non-empty case
*/ */
pnode->nd_lab = ++text_label; pnode->nd_lab = ++text_label;
casecnt++;
if (! AddCases(sh, /* to descriptor */ if (! AddCases(sh, /* to descriptor */
pnode->nd_left->nd_left, pnode->nd_left->nd_left,
/* of case labels */ /* of case labels */
@ -105,6 +107,17 @@ CaseCode(nd, exitlabel)
} }
} }
if (!casecnt) {
/* There were no cases, so we have to check the case-expression
here
*/
if (! (sh->sh_type->tp_fund & T_DISCRETE)) {
node_error(nd, "illegal type in CASE-expression");
FreeSh(sh);
return;
}
}
/* Now generate code for the switch itself /* Now generate code for the switch itself
First the part that CSA and CSB descriptions have in common. First the part that CSA and CSB descriptions have in common.
*/ */
@ -232,7 +245,7 @@ AddOneCase(sh, node, lbl)
ce->ce_label = lbl; ce->ce_label = lbl;
ce->ce_value = node->nd_INT; ce->ce_value = node->nd_INT;
if (! TstCompat(sh->sh_type, node->nd_type)) { if (! TstCompat(sh->sh_type, node->nd_type)) {
node_error(node, "Type incompatibility in case"); node_error(node, "type incompatibility in case");
free_case_entry(ce); free_case_entry(ce);
return 0; return 0;
} }

3
lang/m2/comp/chk_expr.c
View file

@ -21,6 +21,7 @@
#include "standards.h" #include "standards.h"
#include "chk_expr.h" #include "chk_expr.h"
#include "misc.h" #include "misc.h"
#include "warning.h"
extern char *symbol2str(); extern char *symbol2str();
@ -936,7 +937,7 @@ node_error(left, "illegal type in %s", std == S_MAX ? "MAX" : "MIN");
if (!warning_given) { if (!warning_given) {
warning_given = 1; warning_given = 1;
node_warning(expp, "NEW and DISPOSE are old-fashioned"); node_warning(expp, W_OLDFASHIONED, "NEW and DISPOSE are old-fashioned");
} }
} }
if (! (left = getvariable(&arg))) return 0; if (! (left = getvariable(&arg))) return 0;

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

@ -13,6 +13,7 @@
#include "node.h" #include "node.h"
#include "Lpars.h" #include "Lpars.h"
#include "standards.h" #include "standards.h"
#include "warning.h"
long mach_long_sign; /* sign bit of the machine long */ long mach_long_sign; /* sign bit of the machine long */
int mach_long_size; /* size of long on this machine == sizeof(long) */ int mach_long_size; /* size of long on this machine == sizeof(long) */
@ -22,6 +23,8 @@ arith max_unsigned; /* maximum unsigned on target machine */
arith max_longint; /* maximum longint on target machine */ arith max_longint; /* maximum longint on target machine */
arith wrd_bits; /* number of bits in a word */ arith wrd_bits; /* number of bits in a word */
static char ovflow[] = "overflow in constant expression";
cstunary(expp) cstunary(expp)
register struct node *expp; register struct node *expp;
{ {
@ -485,7 +488,7 @@ cstcall(expp, call)
|| expp->nd_INT >= expp->nd_type->enm_ncst || expp->nd_INT >= expp->nd_type->enm_ncst
) )
) )
) node_warning(expp,"overflow in constant expression"); ) node_warning(expp, W_ORDINARY, ovflow);
else CutSize(expp); else CutSize(expp);
break; break;
@ -512,8 +515,7 @@ CutSize(expr)
uns = (tp->tp_fund & (T_CARDINAL|T_CHAR)); uns = (tp->tp_fund & (T_CARDINAL|T_CHAR));
if (uns) { if (uns) {
if (o1 & ~full_mask[size]) { if (o1 & ~full_mask[size]) {
node_warning(expr, node_warning(expr, W_ORDINARY, ovflow);
"overflow in constant expression");
o1 &= full_mask[size]; o1 &= full_mask[size];
} }
} }
@ -522,7 +524,7 @@ CutSize(expr)
long remainder = o1 & ~full_mask[size]; long remainder = o1 & ~full_mask[size];
if (remainder != 0 && remainder != ~full_mask[size]) { if (remainder != 0 && remainder != ~full_mask[size]) {
node_warning(expr, "overflow in constant expression"); node_warning(expr, W_ORDINARY, ovflow);
o1 <<= nbits; o1 <<= nbits;
o1 >>= nbits; o1 >>= nbits;
} }

10
lang/m2/comp/debug.h Normal file
View file

@ -0,0 +1,10 @@
/* A debugging macro
*/
#include "debugcst.h"
#ifdef DEBUG
#define DO_DEBUG(x, y) ((x) && (y))
#else
#define DO_DEBUG(x, y)
#endif

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

@ -17,6 +17,7 @@
#include "misc.h" #include "misc.h"
#include "main.h" #include "main.h"
#include "chk_expr.h" #include "chk_expr.h"
#include "warning.h"
int proclevel = 0; /* nesting level of procedures */ int proclevel = 0; /* nesting level of procedures */
int return_occurred; /* set if a return occurs in a block */ int return_occurred; /* set if a return occurs in a block */
@ -162,7 +163,7 @@ enumeration(struct type **ptp;)
*ptp = standard_type(T_ENUMERATION, 1, (arith) 1); *ptp = standard_type(T_ENUMERATION, 1, (arith) 1);
EnterEnumList(EnumList, *ptp); EnterEnumList(EnumList, *ptp);
if ((*ptp)->enm_ncst > 256) { /* ??? is this reasonable ??? */ if ((*ptp)->enm_ncst > 256) { /* ??? is this reasonable ??? */
error("Too many enumeration literals"); error("too many enumeration literals");
} }
} }
; ;
@ -277,7 +278,7 @@ FieldList(struct scope *scope; arith *cnt; int *palign;)
| /* Old fashioned! the first qualident now represents | /* Old fashioned! the first qualident now represents
the type the type
*/ */
{ warning("Old fashioned Modula-2 syntax; ':' missing"); { warning(W_OLDFASHIONED, "old fashioned Modula-2 syntax; ':' missing");
if (ChkDesignator(nd) && if (ChkDesignator(nd) &&
(nd->nd_class != Def || (nd->nd_class != Def ||
!(nd->nd_def->df_kind&(D_ERROR|D_ISTYPE)) || !(nd->nd_def->df_kind&(D_ERROR|D_ISTYPE)) ||
@ -297,7 +298,7 @@ FieldList(struct scope *scope; arith *cnt; int *palign;)
scope, scope,
D_FIELD); D_FIELD);
if (!(tp->tp_fund & T_DISCRETE)) { if (!(tp->tp_fund & T_DISCRETE)) {
error("Illegal type in variant"); error("illegal type in variant");
} }
df->df_type = tp; df->df_type = tp;
df->fld_off = align(*cnt, tp->tp_align); df->fld_off = align(*cnt, tp->tp_align);
@ -386,18 +387,36 @@ PointerType(struct type **ptp;)
} : } :
POINTER TO POINTER TO
{ *ptp = construct_type(T_POINTER, NULLTYPE); } { *ptp = construct_type(T_POINTER, NULLTYPE); }
[ %if ( lookup(dot.TOK_IDF, CurrentScope)) [ %if ( lookup(dot.TOK_IDF, CurrentScope)
/* Either a Module or a Type, but in both cases defined /* Either a Module or a Type, but in both cases defined
in this scope, so this is the correct identification in this scope, so this is the correct identification
*/ */
qualtype(&((*ptp)->next)) ||
| %if ( nd = new_node(), ( nd = new_node(),
nd->nd_token = dot, nd->nd_token = dot,
lookfor(nd, CurrVis, 0)->df_kind == D_MODULE) lookfor(nd, CurrVis, 0)->df_kind == D_MODULE
)
/* A Modulename in one of the enclosing scopes.
It is not clear from the language definition that
it is correct to handle these like this, but
existing compilers do it like this, and the
alternative is difficult with a lookahead of only
one token.
???
*/
)
type(&((*ptp)->next)) type(&((*ptp)->next))
{ if (nd) free_node(nd); } { if (nd) free_node(nd); }
| |
IDENT { Forward(nd, (*ptp)); } IDENT { if (nd) {
/* nd could be a null pointer, if we had a
syntax error exactly at this alternation.
MORAL: Be careful with %if resolvers with
side effects!
*/
Forward(nd, (*ptp));
}
}
] ]
; ;

56
lang/m2/comp/defmodule.c
View file

@ -15,13 +15,13 @@
#include "f_info.h" #include "f_info.h"
#include "main.h" #include "main.h"
#include "node.h" #include "node.h"
#include "type.h"
#ifdef DEBUG #ifdef DEBUG
long sys_filesize(); long sys_filesize();
#endif #endif
struct idf * CurrentId; STATIC
GetFile(name) GetFile(name)
char *name; char *name;
{ {
@ -35,10 +35,12 @@ GetFile(name)
buf[10] = '\0'; /* maximum length */ buf[10] = '\0'; /* maximum length */
strcat(buf, ".def"); strcat(buf, ".def");
if (! InsertFile(buf, DEFPATH, &(FileName))) { if (! InsertFile(buf, DEFPATH, &(FileName))) {
fatal("Could'nt find a DEFINITION MODULE for \"%s\"", name); error("could'nt find a DEFINITION MODULE for \"%s\"", name);
return 0;
} }
LineNumber = 1; LineNumber = 1;
DO_DEBUG(options['F'], debug("File %s : %ld characters", FileName, sys_filesize(FileName))); DO_DEBUG(options['F'], debug("File %s : %ld characters", FileName, sys_filesize(FileName)));
return 1;
} }
struct def * struct def *
@ -52,6 +54,7 @@ GetDefinitionModule(id, incr)
*/ */
struct def *df; struct def *df;
static int level; static int level;
struct scopelist *vis;
level += incr; level += incr;
df = lookup(id, GlobalScope); df = lookup(id, GlobalScope);
@ -62,33 +65,40 @@ GetDefinitionModule(id, incr)
do_SYSTEM(); do_SYSTEM();
} }
else { else {
GetFile(id->id_text);
CurrentId = id;
open_scope(CLOSEDSCOPE); open_scope(CLOSEDSCOPE);
DefModule(); if (GetFile(id->id_text)) {
if (level == 1) { DefModule();
/* The module is directly imported by the if (level == 1) {
currently defined module, so we have to /* The module is directly imported by
remember its name because we have to call the currently defined module, so we
its initialization routine have to remember its name because
*/ we have to call its initialization
static struct node *nd_end; /* end of list */ routine
register struct node *n; */
extern struct node *Modules; static struct node *nd_end;
register struct node *n;
extern struct node *Modules;
n = MkLeaf(Name, &dot); n = MkLeaf(Name, &dot);
n->nd_IDF = id; n->nd_IDF = id;
n->nd_symb = IDENT; n->nd_symb = IDENT;
if (nd_end) nd_end->next = n; if (nd_end) nd_end->next = n;
else Modules = n; else Modules = n;
nd_end = n; nd_end = n;
}
} }
vis = CurrVis;
close_scope(SC_CHKFORW); close_scope(SC_CHKFORW);
} }
df = lookup(id, GlobalScope); df = lookup(id, GlobalScope);
if (! df) {
df = MkDef(id, GlobalScope, D_ERROR);
df->df_type = error_type;
df->mod_vis = CurrVis;
return df;
}
} }
CurrentId = 0; assert(df);
assert(df && df->df_kind == D_MODULE);
level -= incr; level -= incr;
return df; return df;
} }

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

@ -116,7 +116,7 @@ EnterVarList(Idlist, type, local)
df->df_flags |= D_NOREG; df->df_flags |= D_NOREG;
if (idlist->nd_left->nd_type != card_type) { if (idlist->nd_left->nd_type != card_type) {
node_error(idlist->nd_left, node_error(idlist->nd_left,
"Illegal type for address"); "illegal type for address");
} }
df->var_off = idlist->nd_left->nd_INT; df->var_off = idlist->nd_left->nd_INT;
} }
@ -235,17 +235,20 @@ DoImport(df, scope)
} }
STATIC struct scopelist * STATIC struct scopelist *
ForwModule(df, idn) ForwModule(df, nd)
register struct def *df; register struct def *df;
struct node *idn; struct node *nd;
{ {
/* An import is done from a not yet defined module "idn". /* An import is done from a not yet defined module "df".
We could also end up here for not found DEFINITION MODULES.
Create a declaration and a scope for this module. Create a declaration and a scope for this module.
*/ */
struct scopelist *vis; struct scopelist *vis;
df->df_scope = enclosing(CurrVis)->sc_scope; if (df->df_scope != GlobalScope) {
df->df_kind = D_FORWMODULE; df->df_scope = enclosing(CurrVis)->sc_scope;
df->df_kind = D_FORWMODULE;
}
open_scope(CLOSEDSCOPE); open_scope(CLOSEDSCOPE);
vis = CurrVis; /* The new scope, but watch out, it's "sc_encl" vis = CurrVis; /* The new scope, but watch out, it's "sc_encl"
field is not set right. It must indicate the field is not set right. It must indicate the
@ -256,7 +259,7 @@ ForwModule(df, idn)
vis->sc_encl = enclosing(CurrVis); vis->sc_encl = enclosing(CurrVis);
/* Here ! */ /* Here ! */
df->for_vis = vis; df->for_vis = vis;
df->for_node = MkLeaf(Name, &(idn->nd_token)); df->for_node = nd;
return vis; return vis;
} }
@ -289,7 +292,9 @@ EnterExportList(Idlist, qualified)
register struct def *df, *df1; register struct def *df, *df1;
for (;idlist; idlist = idlist->next) { for (;idlist; idlist = idlist->next) {
df = lookup(idlist->nd_IDF, CurrentScope); extern struct def *NoImportlookup();
df = NoImportlookup(idlist->nd_IDF, CurrentScope);
if (!df) { if (!df) {
/* undefined item in export list /* undefined item in export list
@ -306,6 +311,8 @@ EnterExportList(Idlist, qualified)
idlist->nd_IDF->id_text); idlist->nd_IDF->id_text);
} }
if (df->df_kind == D_IMPORT) df = df->imp_def;
df->df_flags |= qualified; df->df_flags |= qualified;
if (qualified == D_EXPORTED) { if (qualified == D_EXPORTED) {
/* Export, but not qualified. /* Export, but not qualified.
@ -357,9 +364,10 @@ EnterExportList(Idlist, qualified)
FreeNode(Idlist); FreeNode(Idlist);
} }
EnterFromImportList(Idlist, FromDef) EnterFromImportList(Idlist, FromDef, FromId)
struct node *Idlist; struct node *Idlist;
register struct def *FromDef; register struct def *FromDef;
struct node *FromId;
{ {
/* Import the list Idlist from the module indicated by Fromdef. /* Import the list Idlist from the module indicated by Fromdef.
*/ */
@ -373,9 +381,11 @@ EnterFromImportList(Idlist, FromDef)
/* The module from which the import was done /* The module from which the import was done
is not yet declared. I'm not sure if I must is not yet declared. I'm not sure if I must
accept this, but for the time being I will. accept this, but for the time being I will.
We also end up here if some definition module could not
be found.
??? ???
*/ */
vis = ForwModule(FromDef, FromDef->df_idf); vis = ForwModule(FromDef, FromId);
forwflag = 1; forwflag = 1;
break; break;
case D_FORWMODULE: case D_FORWMODULE:
@ -385,7 +395,7 @@ EnterFromImportList(Idlist, FromDef)
vis = FromDef->mod_vis; vis = FromDef->mod_vis;
break; break;
default: default:
error("identifier \"%s\" does not represent a module", node_error(FromId, "identifier \"%s\" does not represent a module",
FromDef->df_idf->id_text); FromDef->df_idf->id_text);
break; break;
} }
@ -405,6 +415,7 @@ EnterFromImportList(Idlist, FromDef)
DoImport(df, CurrentScope); DoImport(df, CurrentScope);
} }
if (!forwflag) FreeNode(FromId);
FreeNode(Idlist); FreeNode(Idlist);
} }

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

@ -17,6 +17,7 @@
#include "LLlex.h" #include "LLlex.h"
#include "main.h" #include "main.h"
#include "node.h" #include "node.h"
#include "warning.h"
/* error classes */ /* error classes */
#define ERROR 1 #define ERROR 1
@ -30,6 +31,7 @@
#endif #endif
int err_occurred; int err_occurred;
static int warn_class;
extern char *symbol2str(); extern char *symbol2str();
@ -69,18 +71,20 @@ node_error(node, fmt, args)
} }
/*VARARGS1*/ /*VARARGS1*/
warning(fmt, args) warning(class, fmt, args)
char *fmt; char *fmt;
{ {
_error(WARNING, NULLNODE, fmt, &args); warn_class = class;
if (class & warning_classes) _error(WARNING, NULLNODE, fmt, &args);
} }
/*VARARGS2*/ /*VARARGS2*/
node_warning(node, fmt, args) node_warning(node, class, fmt, args)
struct node *node; struct node *node;
char *fmt; char *fmt;
{ {
_error(WARNING, node, fmt, &args); warn_class = class;
if (class & warning_classes) _error(WARNING, node, fmt, &args);
} }
/*VARARGS1*/ /*VARARGS1*/
@ -91,10 +95,11 @@ lexerror(fmt, args)
} }
/*VARARGS1*/ /*VARARGS1*/
lexwarning(fmt, args) lexwarning(class, fmt, args)
char *fmt; char *fmt;
{ {
_error(LEXWARNING, NULLNODE, fmt, &args); warn_class = class;
if (class & warning_classes) _error(LEXWARNING, NULLNODE, fmt, &args);
} }
/*VARARGS1*/ /*VARARGS1*/
@ -149,19 +154,23 @@ _error(class, node, fmt, argv)
if (C_busy()) C_ms_err(); if (C_busy()) C_ms_err();
err_occurred = 1; err_occurred = 1;
break; break;
case WARNING:
case LEXWARNING:
if (options['w'])
return;
break;
} }
/* the remark */ /* the remark */
switch (class) { switch (class) {
case WARNING: case WARNING:
case LEXWARNING: case LEXWARNING:
remark = "(warning)"; switch(warn_class) {
case W_OLDFASHIONED:
remark = "(old-fashioned use)";
break;
case W_STRICT:
remark = "(strict)";
break;
default:
remark = "(warning)";
break;
}
break; break;
case CRASH: case CRASH:
remark = "CRASH\007"; remark = "CRASH\007";

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

@ -15,6 +15,9 @@
#include "const.h" #include "const.h"
#include "type.h" #include "type.h"
#include "chk_expr.h" #include "chk_expr.h"
#include "warning.h"
extern char options[];
} }
number(struct node **p;) : number(struct node **p;) :
@ -93,7 +96,7 @@ ConstExpression(struct node **pnd;):
DO_DEBUG(options['X'], PrNode(*pnd, 0)); DO_DEBUG(options['X'], PrNode(*pnd, 0));
if (ChkExpression(*pnd) && if (ChkExpression(*pnd) &&
((*pnd)->nd_class != Set && (*pnd)->nd_class != Value)) { ((*pnd)->nd_class != Set && (*pnd)->nd_class != Value)) {
error("Constant expression expected"); error("constant expression expected");
} }
DO_DEBUG(options['X'], print("RESULTS IN\n")); DO_DEBUG(options['X'], print("RESULTS IN\n"));
DO_DEBUG(options['X'], PrNode(*pnd, 0)); DO_DEBUG(options['X'], PrNode(*pnd, 0));
@ -234,7 +237,8 @@ designator(struct node **pnd;)
designator_tail(struct node **pnd;): designator_tail(struct node **pnd;):
visible_designator_tail(pnd) visible_designator_tail(pnd)
[ [ %persistent
%default
selector(pnd) selector(pnd)
| |
visible_designator_tail(pnd) visible_designator_tail(pnd)

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

@ -10,16 +10,12 @@ struct f_info file_info;
#include "scope.h" #include "scope.h"
#include <inp_pkg.body> #include <inp_pkg.body>
extern struct idf *CurrentId;
AtEoIF() AtEoIF()
{ {
/* Make the unstacking of input streams noticable to the /* Make the unstacking of input streams noticable to the
lexical analyzer lexical analyzer
*/ */
if (CurrentId && ! lookup(CurrentId, GlobalScope)) {
fatal("No definition module read for \"%s\"", CurrentId->id_text);
}
return 1; return 1;
} }

32
lang/m2/comp/lookup.c
View file

@ -51,6 +51,38 @@ lookup(id, scope)
return df; return df;
} }
struct def *
NoImportlookup(id, scope)
register struct idf *id;
struct scope *scope;
{
/* Look up a definition of an identifier in scope "scope".
Make the "def" list self-organizing.
Don't check if the definition is imported!
*/
register struct def *df, *df1;
/* Look in the chain of definitions of this "id" for one with scope
"scope".
*/
for (df = id->id_def, df1 = 0;
df && df->df_scope != scope;
df1 = df, df = df->next) { /* nothing */ }
if (df) {
/* Found it
*/
if (df1) {
/* Put the definition in front
*/
df1->next = df->next;
df->next = id->id_def;
id->id_def = df;
}
}
return df;
}
struct def * struct def *
lookfor(id, vis, give_error) lookfor(id, vis, give_error)
register struct node *id; register struct node *id;

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

@ -18,6 +18,7 @@
#include "standards.h" #include "standards.h"
#include "tokenname.h" #include "tokenname.h"
#include "node.h" #include "node.h"
#include "warning.h"
int state; /* either IMPLEMENTATION or PROGRAM */ int state; /* either IMPLEMENTATION or PROGRAM */
char options[128]; char options[128];
@ -35,6 +36,7 @@ main(argc, argv)
register char **Nargv = &argv[0]; register char **Nargv = &argv[0];
ProgName = *argv++; ProgName = *argv++;
warning_classes = W_INITIAL;
while (--argc > 0) { while (--argc > 0) {
if (**argv == '-') if (**argv == '-')
@ -78,7 +80,7 @@ Compile(src, dst)
open_scope(CLOSEDSCOPE); open_scope(CLOSEDSCOPE);
GlobalScope = CurrentScope; GlobalScope = CurrentScope;
C_init(word_size, pointer_size); 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_magic();
C_ms_emx(word_size, pointer_size); C_ms_emx(word_size, pointer_size);
CompUnit(); CompUnit();
@ -199,7 +201,7 @@ do_SYSTEM()
(void) Enter("ADR", D_PROCEDURE, std_type, S_ADR); (void) Enter("ADR", D_PROCEDURE, std_type, S_ADR);
(void) Enter("TSIZE", D_PROCEDURE, std_type, S_TSIZE); (void) Enter("TSIZE", D_PROCEDURE, std_type, S_TSIZE);
if (!InsertText(SYSTEM, sizeof(SYSTEM) - 1)) { if (!InsertText(SYSTEM, sizeof(SYSTEM) - 1)) {
fatal("Could not insert text"); fatal("could not insert text");
} }
DefModule(); DefModule();
close_scope(SC_CHKFORW); close_scope(SC_CHKFORW);

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

@ -18,7 +18,7 @@ match_id(id1, id2)
first place, and if not, give an error message first place, and if not, give an error message
*/ */
if (id1 != id2 && !is_anon_idf(id1) && !is_anon_idf(id2)) { if (id1 != id2 && !is_anon_idf(id1) && !is_anon_idf(id2)) {
error("Name \"%s\" does not match block name \"%s\"", error("name \"%s\" does not match block name \"%s\"",
id1->id_text, id1->id_text,
id2->id_text id2->id_text
); );

39
lang/m2/comp/options.c
View file

@ -8,9 +8,11 @@
#include "type.h" #include "type.h"
#include "main.h" #include "main.h"
#include "warning.h"
extern int idfsize; extern int idfsize;
static int ndirs; static int ndirs;
int warning_classes;
DoOption(text) DoOption(text)
register char *text; register char *text;
@ -29,6 +31,41 @@ DoOption(text)
*/ */
case 'w':
if (*text) {
while (*text) {
switch(*text++) {
case 'O':
warning_classes &= ~W_OLDFASHIONED;
break;
case 'R':
warning_classes &= ~W_STRICT;
break;
case 'W':
warning_classes &= ~W_ORDINARY;
break;
}
}
}
else warning_classes = 0;
break;
case 'W':
while (*text) {
switch(*text++) {
case 'O':
warning_classes |= W_OLDFASHIONED;
break;
case 'R':
warning_classes |= W_STRICT;
break;
case 'W':
warning_classes |= W_ORDINARY;
break;
}
}
break;
case 'M': { /* maximum identifier length */ case 'M': { /* maximum identifier length */
char *t = text; /* because &text is illegal */ char *t = text; /* because &text is illegal */
@ -42,7 +79,7 @@ DoOption(text)
case 'I' : case 'I' :
if (++ndirs >= NDIRS) { if (++ndirs >= NDIRS) {
fatal("Too many -I options"); fatal("too many -I options");
} }
DEFPATH[ndirs] = text; DEFPATH[ndirs] = text;
break; break;

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

@ -15,6 +15,7 @@
#include "type.h" #include "type.h"
#include "node.h" #include "node.h"
#include "f_info.h" #include "f_info.h"
#include "warning.h"
} }
/* /*
@ -62,7 +63,7 @@ priority(arith *pprio;)
} : } :
'[' ConstExpression(&nd) ']' '[' ConstExpression(&nd) ']'
{ if (!(nd->nd_type->tp_fund & T_CARDINAL)) { { if (!(nd->nd_type->tp_fund & T_CARDINAL)) {
node_error(nd, "Illegal priority"); node_error(nd, "illegal priority");
} }
*pprio = nd->nd_INT; *pprio = nd->nd_INT;
FreeNode(nd); FreeNode(nd);
@ -85,23 +86,16 @@ export(int *QUALflag; struct node **ExportList;)
import(int local;) import(int local;)
{ {
struct node *ImportList; struct node *ImportList;
struct node *FromId = 0;
register struct def *df; register struct def *df;
int fromid;
extern struct def *GetDefinitionModule(); extern struct def *GetDefinitionModule();
} : } :
[ FROM [ FROM
IDENT { fromid = 1; IDENT { FromId = MkLeaf(Name, &dot);
if (local) { if (local) df = lookfor(FromId,enclosing(CurrVis),0);
struct node *nd = MkLeaf(Name, &dot); else df = GetDefinitionModule(dot.TOK_IDF, 1);
df = lookfor(nd,enclosing(CurrVis),0);
FreeNode(nd);
}
else df = GetDefinitionModule(dot.TOK_IDF, 1);
} }
| ]?
{ fromid = 0; }
]
IMPORT IdentList(&ImportList) ';' IMPORT IdentList(&ImportList) ';'
/* /*
When parsing a global module, this is the place where we must When parsing a global module, this is the place where we must
@ -109,7 +103,9 @@ import(int local;)
If the FROM clause is present, the identifier in it is a module If the FROM clause is present, the identifier in it is a module
name, otherwise the names in the import list are module names. name, otherwise the names in the import list are module names.
*/ */
{ if (fromid) EnterFromImportList(ImportList, df); { if (FromId) {
EnterFromImportList(ImportList, df, FromId);
}
else EnterImportList(ImportList, local); else EnterImportList(ImportList, local);
} }
; ;
@ -137,7 +133,7 @@ DefinitionModule
modules. Issue a warning. modules. Issue a warning.
*/ */
{ {
node_warning(exportlist, "export list in definition module ignored"); node_warning(exportlist, W_ORDINARY, "export list in definition module ignored");
FreeNode(exportlist); FreeNode(exportlist);
} }
| |
@ -161,7 +157,7 @@ definition
register struct def *df; register struct def *df;
struct def *dummy; struct def *dummy;
} : } :
CONST [ ConstantDeclaration Semicolon ]* CONST [ ConstantDeclaration ';' ]*
| |
TYPE TYPE
[ IDENT { df = define(dot.TOK_IDF, CurrentScope, D_TYPE); } [ IDENT { df = define(dot.TOK_IDF, CurrentScope, D_TYPE); }
@ -176,21 +172,13 @@ definition
df->df_type = construct_type(T_HIDDEN, NULLTYPE); df->df_type = construct_type(T_HIDDEN, NULLTYPE);
} }
] ]
Semicolon ';'
]* ]*
| |
VAR [ VariableDeclaration Semicolon ]* VAR [ VariableDeclaration ';' ]*
| |
ProcedureHeading(&dummy, D_PROCHEAD) ProcedureHeading(&dummy, D_PROCHEAD)
Semicolon
;
/* The next nonterminal is used to relax the grammar a little.
*/
Semicolon:
';' ';'
|
/* empty */ { warning("; expected"); }
; ;
ProgramModule ProgramModule

3
lang/m2/comp/scope.C
View file

@ -18,6 +18,7 @@ struct scope *PervasiveScope, *GlobalScope;
struct scopelist *CurrVis; struct scopelist *CurrVis;
extern int proclevel; extern int proclevel;
static struct scopelist *PervVis; static struct scopelist *PervVis;
extern char options[];
/* STATICALLOCDEF "scope" 10 */ /* STATICALLOCDEF "scope" 10 */
@ -107,7 +108,7 @@ chk_proc(df)
STATIC STATIC
chk_forw(pdf) chk_forw(pdf)
struct def **pdf; register struct def **pdf;
{ {
/* Called at scope close. Look for all forward definitions and /* Called at scope close. Look for all forward definitions and
if the scope was a closed scope, give an error message for if the scope was a closed scope, give an error message for

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

@ -92,7 +92,7 @@ reserve(resv)
while (resv->tn_symbol) { while (resv->tn_symbol) {
p = str2idf(resv->tn_name, 0); p = str2idf(resv->tn_name, 0);
if (!p) fatal("Out of Memory"); if (!p) fatal("out of Memory");
p->id_reserved = resv->tn_symbol; p->id_reserved = resv->tn_symbol;
resv++; resv++;
} }

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

@ -107,7 +107,9 @@ align(pos, al)
arith pos; arith pos;
int al; int al;
{ {
return ((pos + al - 1) / al) * al; arith i;
return pos + ((i = pos % al) ? al - i : 0);
} }
struct type * struct type *
@ -209,25 +211,25 @@ chk_basesubrange(tp, base)
of "base". of "base".
*/ */
if (base->sub_lb > tp->sub_lb || base->sub_ub < tp->sub_ub) { if (base->sub_lb > tp->sub_lb || base->sub_ub < tp->sub_ub) {
error("Base type has insufficient range"); error("base type has insufficient range");
} }
base = base->next; base = base->next;
} }
if (base->tp_fund & (T_ENUMERATION|T_CHAR)) { if (base->tp_fund & (T_ENUMERATION|T_CHAR)) {
if (tp->next != base) { if (tp->next != base) {
error("Specified base does not conform"); error("specified base does not conform");
} }
} }
else if (base != card_type && base != int_type) { else if (base != card_type && base != int_type) {
error("Illegal base for a subrange"); error("illegal base for a subrange");
} }
else if (base == int_type && tp->next == card_type && else if (base == int_type && tp->next == card_type &&
(tp->sub_ub > max_int || tp->sub_ub < 0)) { (tp->sub_ub > max_int || tp->sub_ub < 0)) {
error("Upperbound to large for type INTEGER"); error("upperbound to large for type INTEGER");
} }
else if (base != tp->next && base != int_type) { else if (base != tp->next && base != int_type) {
error("Specified base does not conform"); error("specified base does not conform");
} }
tp->next = base; tp->next = base;
@ -246,7 +248,7 @@ subr_type(lb, ub)
register struct type *tp = BaseType(lb->nd_type), *res; register struct type *tp = BaseType(lb->nd_type), *res;
if (!TstCompat(lb->nd_type, ub->nd_type)) { if (!TstCompat(lb->nd_type, ub->nd_type)) {
node_error(ub, "Types of subrange bounds not equal"); node_error(ub, "types of subrange bounds not equal");
return error_type; return error_type;
} }
@ -261,14 +263,14 @@ subr_type(lb, ub)
/* Check base type /* Check base type
*/ */
if (! (tp->tp_fund & T_DISCRETE)) { if (! (tp->tp_fund & T_DISCRETE)) {
node_error(ub, "Illegal base type for subrange"); node_error(ub, "illegal base type for subrange");
return error_type; return error_type;
} }
/* Check bounds /* Check bounds
*/ */
if (lb->nd_INT > ub->nd_INT) { if (lb->nd_INT > ub->nd_INT) {
node_error(ub, "Lower bound exceeds upper bound"); node_error(ub, "lower bound exceeds upper bound");
} }
/* Now construct resulting type /* Now construct resulting type
@ -361,12 +363,12 @@ set_type(tp)
getbounds(tp, &lb, &ub); getbounds(tp, &lb, &ub);
if (lb < 0 || ub > MAXSET-1) { if (lb < 0 || ub > MAXSET-1) {
error("Set type limits exceeded"); error("set type limits exceeded");
return error_type; return error_type;
} }
tp = construct_type(T_SET, tp); tp = construct_type(T_SET, tp);
tp->tp_size = WA(((ub - lb) + 8)/8); tp->tp_size = WA(((ub - lb) + 8) >> 3);
return tp; return tp;
} }
@ -406,7 +408,7 @@ ArraySizes(tp)
/* check index type /* check index type
*/ */
if (! bounded(index_type)) { if (! bounded(index_type)) {
error("Illegal index type"); error("illegal index type");
tp->tp_size = 0; tp->tp_size = 0;
return; return;
} }

3
lang/m2/comp/typequiv.c
View file

@ -13,6 +13,7 @@
#include "def.h" #include "def.h"
#include "LLlex.h" #include "LLlex.h"
#include "node.h" #include "node.h"
#include "warning.h"
int int
TstTypeEquiv(tp1, tp2) TstTypeEquiv(tp1, tp2)
@ -218,7 +219,7 @@ TstParCompat(formaltype, actualtype, VARflag, nd)
( VARflag ( VARflag
&& ( TstCompat(formaltype, actualtype) && ( TstCompat(formaltype, actualtype)
&& &&
(node_warning(nd, "oldfashioned! types of formal and actual must be identical"), (node_warning(nd, W_OLDFASHIONED, "types of formal and actual must be identical"),
1) 1)
) )
) )

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

@ -24,6 +24,7 @@
#include "idf.h" #include "idf.h"
#include "chk_expr.h" #include "chk_expr.h"
#include "walk.h" #include "walk.h"
#include "warning.h"
extern arith NewPtr(); extern arith NewPtr();
extern arith NewInt(); extern arith NewInt();
@ -147,7 +148,7 @@ WalkProcedure(procedure)
DoProfil(); DoProfil();
TmpOpen(sc); TmpOpen(sc);
func_type = tp = ResultType(procedure->df_type); func_type = tp = RemoveEqual(ResultType(procedure->df_type));
if (tp && IsConstructed(tp)) { if (tp && IsConstructed(tp)) {
/* The result type of this procedure is constructed. /* The result type of this procedure is constructed.
@ -678,7 +679,7 @@ DoForInit(nd, left)
node_error(nd, "type incompatibility in FOR statement"); node_error(nd, "type incompatibility in FOR statement");
return 0; return 0;
} }
node_warning(nd, "old-fashioned! compatibility required in FOR statement"); node_warning(nd, W_OLDFASHIONED, "compatibility required in FOR statement");
} }
return 1; return 1;

18
lang/m2/comp/warning.h Normal file
View file

@ -0,0 +1,18 @@
/* Warning classes, at the moment three of them:
Strict (R)
Ordinary (W)
Old-fashioned(O)
*/
/* Bits for a bit mask: */
#define W_ORDINARY 1
#define W_STRICT 2
#define W_OLDFASHIONED 4
#define W_ALL (W_ORDINARY|W_STRICT|W_OLDFASHIONED)
#define W_INITIAL (W_ORDINARY | W_OLDFASHIONED)
/* The bit mask itself: */
extern int warning_classes;