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 "LLlex.h"
#include "const.h"
#include "warning.h"
long str2long();
@ -29,6 +30,8 @@ int idfsize = IDFSIZE;
extern int cntlines;
#endif
static int eofseen;
STATIC
SkipComment()
{
@ -104,6 +107,81 @@ GetString(upto)
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
LLlex()
{
@ -113,7 +191,6 @@ LLlex()
register struct token *tk = ˙
char buf[(IDFSIZE > NUMSIZE ? IDFSIZE : NUMSIZE) + 2];
register int ch, nch;
static int eofseen;
toktype = error_type;
@ -125,6 +202,7 @@ LLlex()
tk->tk_lineno = LineNumber;
again2:
if (eofseen) {
eofseen = 0;
ch = EOI;
@ -132,8 +210,10 @@ LLlex()
else {
again:
LoadChar(ch);
again1:
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++;
#endif
tk->tk_lineno++;
/* Fall Through */
LoadChar(ch);
if (ch != '#') goto again1;
linedirective();
goto again2;
case STSKIP:
goto again;
@ -192,7 +275,7 @@ again:
return tk->tk_symb = LESSEQUAL;
}
if (nch == '>') {
lexwarning("'<>' is old-fashioned; use '#'");
lexwarning(W_STRICT, "'<>' is old-fashioned; use '#'");
return tk->tk_symb = '#';
}
break;
@ -331,7 +414,7 @@ again:
if (ch == 'C' && base == 8) {
toktype = char_type;
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 &&

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

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

58
lang/m2/comp/Makefile
View file

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

8
lang/m2/comp/Parameters
View file

@ -45,14 +45,8 @@
#define AL_UNION 1
!File: debug.h
!File: debugcst.h
#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
#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 arith val;
label CaseDescrLab;
int casecnt = 0;
assert(pnode->nd_class == Stat && pnode->nd_symb == CASE);
@ -85,6 +86,7 @@ CaseCode(nd, exitlabel)
/* non-empty case
*/
pnode->nd_lab = ++text_label;
casecnt++;
if (! AddCases(sh, /* to descriptor */
pnode->nd_left->nd_left,
/* 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
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_value = node->nd_INT;
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);
return 0;
}

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

@ -21,6 +21,7 @@
#include "standards.h"
#include "chk_expr.h"
#include "misc.h"
#include "warning.h"
extern char *symbol2str();
@ -936,7 +937,7 @@ node_error(left, "illegal type in %s", std == S_MAX ? "MAX" : "MIN");
if (!warning_given) {
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;

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

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

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 "main.h"
#include "chk_expr.h"
#include "warning.h"
int proclevel = 0; /* nesting level of procedures */
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);
EnterEnumList(EnumList, *ptp);
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
the type
*/
{ warning("Old fashioned Modula-2 syntax; ':' missing");
{ warning(W_OLDFASHIONED, "old fashioned Modula-2 syntax; ':' missing");
if (ChkDesignator(nd) &&
(nd->nd_class != Def ||
!(nd->nd_def->df_kind&(D_ERROR|D_ISTYPE)) ||
@ -297,7 +298,7 @@ FieldList(struct scope *scope; arith *cnt; int *palign;)
scope,
D_FIELD);
if (!(tp->tp_fund & T_DISCRETE)) {
error("Illegal type in variant");
error("illegal type in variant");
}
df->df_type = tp;
df->fld_off = align(*cnt, tp->tp_align);
@ -386,18 +387,36 @@ PointerType(struct type **ptp;)
} :
POINTER TO
{ *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
*/
qualtype(&((*ptp)->next))
| %if ( nd = new_node(),
nd->nd_token = dot,
lookfor(nd, CurrVis, 0)->df_kind == D_MODULE)
[ %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
*/
||
( nd = new_node(),
nd->nd_token = dot,
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))
{ 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 "main.h"
#include "node.h"
#include "type.h"
#ifdef DEBUG
long sys_filesize();
#endif
struct idf * CurrentId;
STATIC
GetFile(name)
char *name;
{
@ -35,10 +35,12 @@ GetFile(name)
buf[10] = '\0'; /* maximum length */
strcat(buf, ".def");
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;
DO_DEBUG(options['F'], debug("File %s : %ld characters", FileName, sys_filesize(FileName)));
return 1;
}
struct def *
@ -52,6 +54,7 @@ GetDefinitionModule(id, incr)
*/
struct def *df;
static int level;
struct scopelist *vis;
level += incr;
df = lookup(id, GlobalScope);
@ -62,33 +65,40 @@ GetDefinitionModule(id, incr)
do_SYSTEM();
}
else {
GetFile(id->id_text);
CurrentId = id;
open_scope(CLOSEDSCOPE);
DefModule();
if (level == 1) {
/* The module is directly imported by the
currently defined module, so we have to
remember its name because we have to call
its initialization routine
*/
static struct node *nd_end; /* end of list */
register struct node *n;
extern struct node *Modules;
if (GetFile(id->id_text)) {
DefModule();
if (level == 1) {
/* The module is directly imported by
the currently defined module, so we
have to remember its name because
we have to call its initialization
routine
*/
static struct node *nd_end;
register struct node *n;
extern struct node *Modules;
n = MkLeaf(Name, &dot);
n->nd_IDF = id;
n->nd_symb = IDENT;
if (nd_end) nd_end->next = n;
else Modules = n;
nd_end = n;
n = MkLeaf(Name, &dot);
n->nd_IDF = id;
n->nd_symb = IDENT;
if (nd_end) nd_end->next = n;
else Modules = n;
nd_end = n;
}
}
vis = CurrVis;
close_scope(SC_CHKFORW);
}
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 && df->df_kind == D_MODULE);
assert(df);
level -= incr;
return df;
}

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

@ -116,7 +116,7 @@ EnterVarList(Idlist, type, local)
df->df_flags |= D_NOREG;
if (idlist->nd_left->nd_type != card_type) {
node_error(idlist->nd_left,
"Illegal type for address");
"illegal type for address");
}
df->var_off = idlist->nd_left->nd_INT;
}
@ -235,17 +235,20 @@ DoImport(df, scope)
}
STATIC struct scopelist *
ForwModule(df, idn)
ForwModule(df, nd)
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.
*/
struct scopelist *vis;
df->df_scope = enclosing(CurrVis)->sc_scope;
df->df_kind = D_FORWMODULE;
if (df->df_scope != GlobalScope) {
df->df_scope = enclosing(CurrVis)->sc_scope;
df->df_kind = D_FORWMODULE;
}
open_scope(CLOSEDSCOPE);
vis = CurrVis; /* The new scope, but watch out, it's "sc_encl"
field is not set right. It must indicate the
@ -256,7 +259,7 @@ ForwModule(df, idn)
vis->sc_encl = enclosing(CurrVis);
/* Here ! */
df->for_vis = vis;
df->for_node = MkLeaf(Name, &(idn->nd_token));
df->for_node = nd;
return vis;
}
@ -289,7 +292,9 @@ EnterExportList(Idlist, qualified)
register struct def *df, *df1;
for (;idlist; idlist = idlist->next) {
df = lookup(idlist->nd_IDF, CurrentScope);
extern struct def *NoImportlookup();
df = NoImportlookup(idlist->nd_IDF, CurrentScope);
if (!df) {
/* undefined item in export list
@ -306,6 +311,8 @@ EnterExportList(Idlist, qualified)
idlist->nd_IDF->id_text);
}
if (df->df_kind == D_IMPORT) df = df->imp_def;
df->df_flags |= qualified;
if (qualified == D_EXPORTED) {
/* Export, but not qualified.
@ -357,9 +364,10 @@ EnterExportList(Idlist, qualified)
FreeNode(Idlist);
}
EnterFromImportList(Idlist, FromDef)
EnterFromImportList(Idlist, FromDef, FromId)
struct node *Idlist;
register struct def *FromDef;
struct node *FromId;
{
/* 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
is not yet declared. I'm not sure if I must
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;
break;
case D_FORWMODULE:
@ -385,7 +395,7 @@ EnterFromImportList(Idlist, FromDef)
vis = FromDef->mod_vis;
break;
default:
error("identifier \"%s\" does not represent a module",
node_error(FromId, "identifier \"%s\" does not represent a module",
FromDef->df_idf->id_text);
break;
}
@ -405,6 +415,7 @@ EnterFromImportList(Idlist, FromDef)
DoImport(df, CurrentScope);
}
if (!forwflag) FreeNode(FromId);
FreeNode(Idlist);
}

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

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

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

@ -15,6 +15,9 @@
#include "const.h"
#include "type.h"
#include "chk_expr.h"
#include "warning.h"
extern char options[];
}
number(struct node **p;) :
@ -93,7 +96,7 @@ ConstExpression(struct node **pnd;):
DO_DEBUG(options['X'], PrNode(*pnd, 0));
if (ChkExpression(*pnd) &&
((*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'], PrNode(*pnd, 0));
@ -234,7 +237,8 @@ designator(struct node **pnd;)
designator_tail(struct node **pnd;):
visible_designator_tail(pnd)
[
[ %persistent
%default
selector(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 <inp_pkg.body>
extern struct idf *CurrentId;
AtEoIF()
{
/* Make the unstacking of input streams noticable to the
lexical analyzer
*/
if (CurrentId && ! lookup(CurrentId, GlobalScope)) {
fatal("No definition module read for \"%s\"", CurrentId->id_text);
}
return 1;
}

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

@ -51,6 +51,38 @@ lookup(id, scope)
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 *
lookfor(id, vis, give_error)
register struct node *id;

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

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

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

@ -8,9 +8,11 @@
#include "type.h"
#include "main.h"
#include "warning.h"
extern int idfsize;
static int ndirs;
int warning_classes;
DoOption(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 */
char *t = text; /* because &text is illegal */
@ -42,7 +79,7 @@ DoOption(text)
case 'I' :
if (++ndirs >= NDIRS) {
fatal("Too many -I options");
fatal("too many -I options");
}
DEFPATH[ndirs] = text;
break;

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

@ -15,6 +15,7 @@
#include "type.h"
#include "node.h"
#include "f_info.h"
#include "warning.h"
}
/*
@ -62,7 +63,7 @@ priority(arith *pprio;)
} :
'[' ConstExpression(&nd) ']'
{ if (!(nd->nd_type->tp_fund & T_CARDINAL)) {
node_error(nd, "Illegal priority");
node_error(nd, "illegal priority");
}
*pprio = nd->nd_INT;
FreeNode(nd);
@ -85,23 +86,16 @@ export(int *QUALflag; struct node **ExportList;)
import(int local;)
{
struct node *ImportList;
struct node *FromId = 0;
register struct def *df;
int fromid;
extern struct def *GetDefinitionModule();
} :
[ FROM
IDENT { fromid = 1;
if (local) {
struct node *nd = MkLeaf(Name, &dot);
df = lookfor(nd,enclosing(CurrVis),0);
FreeNode(nd);
}
else df = GetDefinitionModule(dot.TOK_IDF, 1);
IDENT { FromId = MkLeaf(Name, &dot);
if (local) df = lookfor(FromId,enclosing(CurrVis),0);
else df = GetDefinitionModule(dot.TOK_IDF, 1);
}
|
{ fromid = 0; }
]
]?
IMPORT IdentList(&ImportList) ';'
/*
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
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);
}
;
@ -137,7 +133,7 @@ DefinitionModule
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);
}
|
@ -161,7 +157,7 @@ definition
register struct def *df;
struct def *dummy;
} :
CONST [ ConstantDeclaration Semicolon ]*
CONST [ ConstantDeclaration ';' ]*
|
TYPE
[ IDENT { df = define(dot.TOK_IDF, CurrentScope, D_TYPE); }
@ -176,21 +172,13 @@ definition
df->df_type = construct_type(T_HIDDEN, NULLTYPE);
}
]
Semicolon
';'
]*
|
VAR [ VariableDeclaration Semicolon ]*
VAR [ VariableDeclaration ';' ]*
|
ProcedureHeading(&dummy, D_PROCHEAD)
Semicolon
;
/* The next nonterminal is used to relax the grammar a little.
*/
Semicolon:
';'
|
/* empty */ { warning("; expected"); }
;
ProgramModule

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

@ -18,6 +18,7 @@ struct scope *PervasiveScope, *GlobalScope;
struct scopelist *CurrVis;
extern int proclevel;
static struct scopelist *PervVis;
extern char options[];
/* STATICALLOCDEF "scope" 10 */
@ -107,7 +108,7 @@ chk_proc(df)
STATIC
chk_forw(pdf)
struct def **pdf;
register struct def **pdf;
{
/* Called at scope close. Look for all forward definitions and
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) {
p = str2idf(resv->tn_name, 0);
if (!p) fatal("Out of Memory");
if (!p) fatal("out of Memory");
p->id_reserved = resv->tn_symbol;
resv++;
}

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

@ -107,7 +107,9 @@ align(pos, al)
arith pos;
int al;
{
return ((pos + al - 1) / al) * al;
arith i;
return pos + ((i = pos % al) ? al - i : 0);
}
struct type *
@ -209,25 +211,25 @@ chk_basesubrange(tp, base)
of "base".
*/
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;
}
if (base->tp_fund & (T_ENUMERATION|T_CHAR)) {
if (tp->next != base) {
error("Specified base does not conform");
error("specified base does not conform");
}
}
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 &&
(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) {
error("Specified base does not conform");
error("specified base does not conform");
}
tp->next = base;
@ -246,7 +248,7 @@ subr_type(lb, ub)
register struct type *tp = BaseType(lb->nd_type), *res;
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;
}
@ -261,14 +263,14 @@ subr_type(lb, ub)
/* Check base type
*/
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;
}
/* Check bounds
*/
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
@ -361,12 +363,12 @@ set_type(tp)
getbounds(tp, &lb, &ub);
if (lb < 0 || ub > MAXSET-1) {
error("Set type limits exceeded");
error("set type limits exceeded");
return error_type;
}
tp = construct_type(T_SET, tp);
tp->tp_size = WA(((ub - lb) + 8)/8);
tp->tp_size = WA(((ub - lb) + 8) >> 3);
return tp;
}
@ -406,7 +408,7 @@ ArraySizes(tp)
/* check index type
*/
if (! bounded(index_type)) {
error("Illegal index type");
error("illegal index type");
tp->tp_size = 0;
return;
}

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

@ -13,6 +13,7 @@
#include "def.h"
#include "LLlex.h"
#include "node.h"
#include "warning.h"
int
TstTypeEquiv(tp1, tp2)
@ -218,7 +219,7 @@ TstParCompat(formaltype, actualtype, VARflag, nd)
( VARflag
&& ( 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)
)
)

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

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