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

Trying to check more of an expression, giving some more sophisticated error messages,and be less wasteful with space for subranges

Browse source
This commit is contained in:
ceriel 1986-11-17 11:41:28 +00:00
parent 22d4d72ef4
commit 9d0ee46068
21 changed files with 280 additions and 240 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -76,10 +76,12 @@ GetString(upto)
/* Read a Modula-2 string, delimited by the character "upto".
*/
register int ch;
register struct string *str = (struct string *) Malloc(sizeof(struct string));
register struct string *str = (struct string *)
Malloc((unsigned) sizeof(struct string));
register char *p;
register int len;
str->s_length = ISTRSIZE;
len = ISTRSIZE;
str->s_str = p = Malloc((unsigned int) ISTRSIZE);
while (LoadChar(ch), ch != upto) {
if (class(ch) == STNL) {
@ -95,15 +97,18 @@ GetString(upto)
break;
}
*p++ = ch;
if (p - str->s_str == str->s_length) {
if (p - str->s_str == len) {
str->s_str = Srealloc(str->s_str,
(unsigned int) str->s_length + RSTRSIZE);
p = str->s_str + str->s_length;
str->s_length += RSTRSIZE;
(unsigned int) len + RSTRSIZE);
p = str->s_str + len;
len += RSTRSIZE;
}
}
*p = '\0';
str->s_length = p - str->s_str;
while (p - str->s_str < len) *p++ = '\0';
if (str->s_length == 0) str->s_length = 1; /* ??? string length
at least 1 ???
*/
return str;
}
@ -172,7 +177,7 @@ linedirective() {
* Remember the file name
*/
if (!eofseen && strcmp(FileName,buf)) {
FileName = Salloc(buf,strlen(buf) + 1);
FileName = Salloc(buf,(unsigned) strlen(buf) + 1);
}
}
if (eofseen) {

4
lang/m2/comp/Makefile
View file

@ -64,8 +64,8 @@ lint: Cfiles
sh -c 'if $(CC) nmclash.c > /dev/null 2>&1 ; then make Xlint ; else sh Resolve Xlint ; fi'
@rm -f nmclash.o a.out
clashes: $(SRC) $(HFILES)
sh -c 'if test -f clashes ; then cclash -l7 clashes $? > Xclashes ; mv Xclashes clashes ; else cclash -l7 $? > clashes ; fi'
longnames: $(SRC) $(HFILES)
sh -c 'if test -f longnames ; then prid -l7 longnames $? > Xlongnames ; mv Xlongnames longnames ; else prid -l7 $? > longnames ; fi'
# entry points not to be used directly

2
lang/m2/comp/Parameters
View file

@ -1,6 +1,6 @@
!File: errout.h
#define ERROUT STDERR /* file pointer for writing messages */
#define MAXERR_LINE 5 /* maximum number of error messages given
#define MAXERR_LINE 100 /* maximum number of error messages given
on the same input line. */

4
lang/m2/comp/Resolve
View file

@ -20,10 +20,10 @@ then
:
else mkdir ../Xsrc
fi
make clashes
make longnames
: remove code generating routines from the clashes list as they are defines.
: code generating routine names start with C_
sed '/^C_/d' < clashes > tmp$$
sed '/^C_/d' < longnames > tmp$$
cclash -c -l7 tmp$$ > ../Xsrc/Xclashes
rm -f tmp$$
PW=`pwd`

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

@ -1 +1 @@
char Version[] = "Version 0.7";
char Version[] = "ACK Modula-2 compiler Version 0.8";

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

@ -25,6 +25,20 @@
extern char *symbol2str();
STATIC
Xerror(nd, mess, edf)
struct node *nd;
char *mess;
struct def *edf;
{
if (edf) {
if (edf->df_kind != D_ERROR) {
node_error(nd, "\"%s\": %s", edf->df_idf->id_text, mess);
}
}
else node_error(nd, "%s", mess);
}
int
ChkVariable(expp)
register struct node *expp;
@ -37,7 +51,7 @@ ChkVariable(expp)
if (expp->nd_class == Def &&
!(expp->nd_def->df_kind & (D_FIELD|D_VARIABLE))) {
node_error(expp, "variable expected");
Xerror(expp, "variable expected", expp->nd_def);
return 0;
}
@ -63,7 +77,7 @@ ChkArrow(expp)
tp = expp->nd_right->nd_type;
if (tp->tp_fund != T_POINTER) {
node_error(expp, "illegal operand for unary operator \"^\"");
node_error(expp, "\"^\": illegal operand");
return 0;
}
@ -82,22 +96,18 @@ ChkArr(expp)
*/
register struct type *tpl, *tpr;
int retval;
assert(expp->nd_class == Arrsel);
assert(expp->nd_symb == '[');
expp->nd_type = error_type;
if (
!ChkVariable(expp->nd_left)
||
!ChkExpression(expp->nd_right)
||
expp->nd_left->nd_type == error_type
) return 0;
retval = ChkVariable(expp->nd_left) & ChkExpression(expp->nd_right);
tpl = expp->nd_left->nd_type;
tpr = expp->nd_right->nd_type;
if (tpl == error_type || tpr == error_type) return 0;
if (tpl->tp_fund != T_ARRAY) {
node_error(expp, "not indexing an ARRAY type");
@ -116,7 +126,7 @@ ChkArr(expp)
}
expp->nd_type = RemoveEqual(tpl->arr_elem);
return 1;
return retval;
}
#ifdef DEBUG
@ -168,11 +178,11 @@ ChkLinkOrName(expp)
!(left->nd_def->df_kind & (D_MODULE|D_VARIABLE|D_FIELD))
)
) {
node_error(left, "illegal selection");
Xerror(left, "illegal selection", left->nd_def);
return 0;
}
if (!(df = lookup(expp->nd_IDF, left->nd_type->rec_scope))) {
if (!(df = lookup(expp->nd_IDF, left->nd_type->rec_scope, 1))) {
id_not_declared(expp);
return 0;
}
@ -184,9 +194,7 @@ ChkLinkOrName(expp)
/* Fields of a record are always D_QEXPORTED,
so ...
*/
node_error(expp, "identifier \"%s\" not exported from qualifying module",
df->df_idf->id_text);
return 0;
Xerror(expp, "not exported from qualifying module", df);
}
}
@ -202,7 +210,6 @@ df->df_idf->id_text);
assert(expp->nd_class == Def);
df = expp->nd_def;
if (df->df_kind == D_ERROR) return 0;
if (df->df_kind & (D_ENUM | D_CONST)) {
/* Replace an enum-literal or a CONST identifier by its value.
@ -220,8 +227,7 @@ df->df_idf->id_text);
expp->nd_lineno = ln;
}
}
return 1;
return df->df_kind != D_ERROR;
}
STATIC int
@ -238,7 +244,7 @@ ChkExLinkOrName(expp)
df = expp->nd_def;
if (!(df->df_kind & D_VALUE)) {
node_error(expp, "value expected");
Xerror(expp, "value expected", df);
}
if (df->df_kind == D_PROCEDURE) {
@ -352,19 +358,18 @@ ChkSet(expp)
/* A type was given. Check it out
*/
if (! ChkDesignator(nd)) return 0;
assert(nd->nd_class == Def);
df = nd->nd_def;
if (!is_type(df) ||
(df->df_type->tp_fund != T_SET)) {
(df->df_type->tp_fund != T_SET)) {
if (df->df_kind != D_ERROR) {
node_error(expp, "type specifier does not represent a set type");
Xerror(expp, "not a set type", df);
}
return 0;
}
tp = df->df_type;
FreeNode(expp->nd_left);
FreeNode(nd);
expp->nd_left = 0;
}
else tp = bitset_type;
@ -412,8 +417,9 @@ node_error(expp, "type specifier does not represent a set type");
}
STATIC struct node *
getarg(argp, bases, designator)
getarg(argp, bases, designator, edf)
struct node **argp;
struct def *edf;
{
/* This routine is used to fetch the next argument from an
argument list. The argument list is indicated by "argp".
@ -427,7 +433,7 @@ getarg(argp, bases, designator)
register struct node *left;
if (! arg) {
node_error(*argp, "too few arguments supplied");
Xerror(*argp, "too few arguments supplied", edf);
return 0;
}
@ -443,7 +449,7 @@ getarg(argp, bases, designator)
if (bases) {
if (!(BaseType(left->nd_type)->tp_fund & bases)) {
node_error(arg, "unexpected type");
Xerror(arg, "unexpected parameter type", edf);
return 0;
}
}
@ -453,8 +459,9 @@ getarg(argp, bases, designator)
}
STATIC struct node *
getname(argp, kinds)
getname(argp, kinds, bases, edf)
struct node **argp;
struct def *edf;
{
/* Get the next argument from argument list "argp".
The argument must indicate a definition, and the
@ -464,7 +471,7 @@ getname(argp, kinds)
register struct node *left;
if (!arg->nd_right) {
node_error(arg, "too few arguments supplied");
Xerror(arg, "too few arguments supplied", edf);
return 0;
}
@ -473,15 +480,22 @@ getname(argp, kinds)
if (! ChkDesignator(left)) return 0;
if (left->nd_class != Def && left->nd_class != LinkDef) {
node_error(arg, "identifier expected");
Xerror(arg, "identifier expected", edf);
return 0;
}
if (!(left->nd_def->df_kind & kinds)) {
node_error(arg, "unexpected type");
Xerror(arg, "unexpected parameter type", edf);
return 0;
}
if (bases) {
if (!(left->nd_type->tp_fund & bases)) {
Xerror(arg, "unexpected parameter type", edf);
return 0;
}
}
*argp = arg;
return left;
}
@ -493,16 +507,25 @@ ChkProcCall(expp)
/* Check a procedure call
*/
register struct node *left;
struct node *arg;
struct def *edf = 0;
register struct paramlist *param;
char ebuf[256];
int retval = 1;
int cnt = 0;
left = expp->nd_left;
if (left->nd_class == Def || left->nd_class == LinkDef) {
edf = left->nd_def;
}
expp->nd_type = RemoveEqual(ResultType(left->nd_type));
/* Check parameter list
*/
for (param = ParamList(left->nd_type); param; param = param->next) {
if (!(left = getarg(&expp, 0, IsVarParam(param)))) return 0;
if (!(left = getarg(&expp, 0, IsVarParam(param), edf))) {
return 0;
}
cnt++;
if (left->nd_symb == STRING) {
TryToString(left, TypeOfParam(param));
}
@ -510,17 +533,19 @@ ChkProcCall(expp)
left->nd_type,
IsVarParam(param),
left)) {
node_error(left, "type incompatibility in parameter");
return 0;
sprint(ebuf, "type incompatibility in parameter %d",
cnt);
Xerror(left, ebuf, edf);
retval = 0;
}
}
if (expp->nd_right) {
node_error(expp->nd_right, "too many parameters supplied");
Xerror(expp->nd_right, "too many parameters supplied", edf);
return 0;
}
return 1;
return retval;
}
int
@ -659,11 +684,12 @@ ChkBinOper(expp)
register struct node *left, *right;
struct type *tpl, *tpr;
int allowed;
int retval;
left = expp->nd_left;
right = expp->nd_right;
if (!ChkExpression(left) || !ChkExpression(right)) return 0;
retval = ChkExpression(left) & ChkExpression(right);
tpl = BaseType(left->nd_type);
tpr = BaseType(right->nd_type);
@ -695,24 +721,27 @@ ChkBinOper(expp)
if (!TstAssCompat(tpl, ElementType(tpr))) {
/* Assignment compatible ???
I don't know! Should we be allowed to check
if a CARDINAL is a member of a BITSET???
if a INTEGER is a member of a BITSET???
*/
node_error(expp, "incompatible types for operator \"IN\"");
node_error(expp, "\"IN\": incompatible types");
return 0;
}
if (left->nd_class == Value && right->nd_class == Set) {
cstset(expp);
}
return 1;
return retval;
}
if (!retval) return 0;
allowed = AllowedTypes(expp->nd_symb);
if (!(tpr->tp_fund & allowed) || !(tpl->tp_fund & allowed)) {
if (!((T_CARDINAL & allowed) &&
ChkAddress(tpl, tpr))) {
node_error(expp,"operator \"%s\": illegal operand type(s)", symbol2str(expp->nd_symb));
node_error(expp, "\"%s\": illegal operand type(s)",
symbol2str(expp->nd_symb));
return 0;
}
if (expp->nd_type->tp_fund & T_CARDINAL) {
@ -721,16 +750,15 @@ node_error(expp,"operator \"%s\": illegal operand type(s)", symbol2str(expp->nd_
}
if (Boolean(expp->nd_symb) && tpl != bool_type) {
node_error(expp,"operator \"%s\": illegal operand type(s)", symbol2str(expp->nd_symb));
node_error(expp, "\"%s\": illegal operand type(s)",
symbol2str(expp->nd_symb));
return 0;
}
/* Operands must be compatible (distilled from Def 8.2)
*/
if (!TstCompat(tpl, tpr)) {
node_error(expp, "incompatible types for operator \"%s\"",
symbol2str(expp->nd_symb));
node_error(expp, "\"%s\": incompatible types", symbol2str(expp->nd_symb));
return 0;
}
@ -810,14 +838,14 @@ ChkUnOper(expp)
default:
crash("ChkUnOper");
}
node_error(expp, "illegal operand for unary operator \"%s\"",
symbol2str(expp->nd_symb));
node_error(expp, "\"%s\": illegal operand", symbol2str(expp->nd_symb));
return 0;
}
STATIC struct node *
getvariable(argp)
getvariable(argp, edf)
struct node **argp;
struct def *edf;
{
/* Get the next argument from argument list "argp".
It must obey the rules of "ChkVariable".
@ -826,7 +854,7 @@ getvariable(argp)
arg = arg->nd_right;
if (!arg) {
node_error(arg, "too few parameters supplied");
Xerror(arg, "too few parameters supplied", edf);
return 0;
}
@ -844,14 +872,16 @@ ChkStandard(expp, left)
/* Check a call of a standard procedure or function
*/
struct node *arg = expp;
register struct def *edf;
int std;
assert(left->nd_class == Def);
std = left->nd_def->df_value.df_stdname;
edf = left->nd_def;
switch(std) {
case S_ABS:
if (!(left = getarg(&arg, T_NUMERIC, 0))) return 0;
if (!(left = getarg(&arg, T_NUMERIC, 0, edf))) return 0;
expp->nd_type = left->nd_type;
if (left->nd_class == Value &&
expp->nd_type->tp_fund != T_REAL) {
@ -861,28 +891,31 @@ ChkStandard(expp, left)
case S_CAP:
expp->nd_type = char_type;
if (!(left = getarg(&arg, T_CHAR, 0))) return 0;
if (!(left = getarg(&arg, T_CHAR, 0, edf))) return 0;
if (left->nd_class == Value) cstcall(expp, S_CAP);
break;
case S_CHR:
expp->nd_type = char_type;
if (!(left = getarg(&arg, T_INTORCARD, 0))) return 0;
if (!(left = getarg(&arg, T_INTORCARD, 0, edf))) return 0;
if (left->nd_class == Value) cstcall(expp, S_CHR);
break;
case S_FLOAT:
expp->nd_type = real_type;
if (!(left = getarg(&arg, T_INTORCARD, 0))) return 0;
if (!(left = getarg(&arg, T_INTORCARD, 0, edf))) return 0;
break;
case S_HIGH:
if (!(left = getarg(&arg, T_ARRAY|T_STRING|T_CHAR, 0))) return 0;
if (!(left = getarg(&arg, T_ARRAY|T_STRING|T_CHAR, 0, edf))) {
return 0;
}
if (IsConformantArray(left->nd_type)) {
/* A conformant array has no explicit index type
??? So, what can we use as index-type ???
/* A conformant array has no explicit index type,
but it is a subrange with lower bound 0, so
it is of type CARDINAL !!!
*/
expp->nd_type = intorcard_type;
expp->nd_type = card_type;
break;
}
if (left->nd_type->tp_fund == T_ARRAY) {
@ -890,14 +923,17 @@ ChkStandard(expp, left)
cstcall(expp, S_MAX);
break;
}
if (left->nd_type->tp_fund == T_CHAR) {
if (left->nd_symb != STRING) {
node_error(left,"HIGH: array parameter expected");
return 0;
}
if (left->nd_symb != STRING) {
Xerror(left,"array parameter expected", edf);
return 0;
}
expp->nd_type = intorcard_type;
expp->nd_type = card_type;
expp->nd_class = Value;
/* Notice that we could disallow HIGH("") here by checking
that left->nd_type->tp_fund != T_CHAR || left->nd_INT != 0.
??? For the time being, we don't. !!!
Maybe the empty string should not be allowed at all.
*/
expp->nd_INT = left->nd_type->tp_fund == T_CHAR ? 0 :
left->nd_SLE - 1;
expp->nd_symb = INTEGER;
@ -905,9 +941,7 @@ ChkStandard(expp, left)
case S_MAX:
case S_MIN:
if (!(left = getname(&arg, D_ISTYPE))) return 0;
if (!(left->nd_type->tp_fund & (T_DISCRETE))) {
node_error(left, "illegal type in %s", std == S_MAX ? "MAX" : "MIN");
if (!(left = getname(&arg, D_ISTYPE, T_DISCRETE, edf))) {
return 0;
}
expp->nd_type = left->nd_type;
@ -915,17 +949,13 @@ node_error(left, "illegal type in %s", std == S_MAX ? "MAX" : "MIN");
break;
case S_ODD:
if (!(left = getarg(&arg, T_INTORCARD, 0))) return 0;
if (!(left = getarg(&arg, T_INTORCARD, 0, edf))) return 0;
expp->nd_type = bool_type;
if (left->nd_class == Value) cstcall(expp, S_ODD);
break;
case S_ORD:
if (!(left = getarg(&arg, T_DISCRETE, 0))) return 0;
if (left->nd_type->tp_size > word_size) {
node_error(left, "illegal type in argument of ORD");
return 0;
}
if (!(left = getarg(&arg, T_DISCRETE, 0, edf))) return 0;
expp->nd_type = card_type;
if (left->nd_class == Value) cstcall(expp, S_ORD);
break;
@ -937,12 +967,12 @@ node_error(left, "illegal type in %s", std == S_MAX ? "MAX" : "MIN");
if (!warning_given) {
warning_given = 1;
node_warning(expp, W_OLDFASHIONED, "NEW and DISPOSE are old-fashioned");
node_warning(expp, W_OLDFASHIONED, "NEW and DISPOSE are obsolete");
}
}
if (! (left = getvariable(&arg))) return 0;
if (! (left = getvariable(&arg, edf))) return 0;
if (! (left->nd_type->tp_fund == T_POINTER)) {
node_error(left, "pointer variable expected");
Xerror(left, "pointer variable expected", edf);
return 0;
}
if (left->nd_class == Def) {
@ -974,23 +1004,19 @@ node_error(left, "illegal type in %s", std == S_MAX ? "MAX" : "MIN");
case S_TSIZE: /* ??? */
case S_SIZE:
expp->nd_type = intorcard_type;
if (! getname(&arg, D_FIELD|D_VARIABLE|D_ISTYPE)) return 0;
if (! getname(&arg, D_FIELD|D_VARIABLE|D_ISTYPE, 0, edf)) {
return 0;
}
cstcall(expp, S_SIZE);
break;
case S_TRUNC:
expp->nd_type = card_type;
if (!(left = getarg(&arg, T_REAL, 0))) return 0;
if (!(left = getarg(&arg, T_REAL, 0, edf))) return 0;
break;
case S_VAL:
{
struct type *tp;
if (!(left = getname(&arg, D_ISTYPE))) return 0;
tp = left->nd_def->df_type;
if (!(tp->tp_fund & T_DISCRETE)) {
node_error(arg, "unexpected type");
if (!(left = getname(&arg, D_ISTYPE, T_DISCRETE, edf))) {
return 0;
}
expp->nd_type = left->nd_def->df_type;
@ -998,26 +1024,25 @@ node_error(left, "illegal type in %s", std == S_MAX ? "MAX" : "MIN");
arg->nd_right = 0;
FreeNode(arg);
arg = expp;
if (!(left = getarg(&arg, T_INTORCARD, 0))) return 0;
if (!(left = getarg(&arg, T_INTORCARD, 0, edf))) return 0;
if (left->nd_class == Value) cstcall(expp, S_VAL);
break;
}
case S_ADR:
expp->nd_type = address_type;
if (!(left = getarg(&arg, 0, 1))) return 0;
if (!(left = getarg(&arg, 0, 1, edf))) return 0;
break;
case S_DEC:
case S_INC:
expp->nd_type = 0;
if (! (left = getvariable(&arg))) return 0;
if (! (left = getvariable(&arg, edf))) return 0;
if (! (left->nd_type->tp_fund & T_DISCRETE)) {
node_error(left,"illegal type in argument of %s",std == S_INC ? "INC" : "DEC");
Xerror(left,"illegal parameter type", edf);
return 0;
}
if (arg->nd_right) {
if (! getarg(&arg, T_INTORCARD, 0)) return 0;
if (! getarg(&arg, T_INTORCARD, 0, edf)) return 0;
}
break;
@ -1031,18 +1056,18 @@ node_error(left,"illegal type in argument of %s",std == S_INC ? "INC" : "DEC");
struct type *tp;
expp->nd_type = 0;
if (!(left = getvariable(&arg))) return 0;
if (!(left = getvariable(&arg, edf))) return 0;
tp = left->nd_type;
if (tp->tp_fund != T_SET) {
node_error(arg, "%s expects a SET parameter", std == S_EXCL ? "EXCL" : "INCL");
Xerror(arg, "SET parameter expected", edf);
return 0;
}
if (!(left = getarg(&arg, T_DISCRETE, 0))) return 0;
if (!(left = getarg(&arg, T_DISCRETE, 0, edf))) return 0;
if (!TstAssCompat(ElementType(tp), left->nd_type)) {
/* What type of compatibility do we want here?
apparently assignment compatibility! ??? ???
*/
node_error(arg, "unexpected type");
Xerror(arg, "unexpected parameter type", edf);
return 0;
}
break;
@ -1053,7 +1078,7 @@ node_error(arg, "%s expects a SET parameter", std == S_EXCL ? "EXCL" : "INCL");
}
if (arg->nd_right) {
node_error(arg->nd_right, "too many parameters supplied");
Xerror(arg->nd_right, "too many parameters supplied", edf);
return 0;
}
@ -1074,7 +1099,7 @@ ChkCast(expp, left)
register struct node *arg = expp->nd_right;
if ((! arg) || arg->nd_right) {
node_error(expp, "only one parameter expected in type cast");
Xerror(expp, "too many parameters in type cast", left->nd_def);
return 0;
}
@ -1084,7 +1109,7 @@ node_error(expp, "only one parameter expected in type cast");
if (arg->nd_type->tp_size != left->nd_type->tp_size &&
(arg->nd_type->tp_size > word_size ||
left->nd_type->tp_size > word_size)) {
node_error(expp, "unequal sizes in type cast");
Xerror(expp, "unequal sizes in type cast", left->nd_def);
}
if (arg->nd_class == Value) {
@ -1132,8 +1157,7 @@ no_desig(expp)
}
STATIC int
done_before(expp)
struct node *expp;
done_before()
{
return 1;
}

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

@ -65,6 +65,7 @@ CodeString(nd)
}
}
STATIC
CodePadString(nd, sz)
register struct node *nd;
arith sz;
@ -96,7 +97,7 @@ CodeExpr(nd, ds, true_label, false_label)
if (tp->tp_fund == T_REAL) fp_used = 1;
switch(nd->nd_class) {
case Def:
if (nd->nd_def->df_kind == D_PROCEDURE) {
if (nd->nd_def->df_kind & (D_PROCEDURE|D_PROCHEAD)) {
C_lpi(NameOfProc(nd->nd_def));
ds->dsg_kind = DSG_LOADED;
break;
@ -380,7 +381,7 @@ CodeParameters(param, arg)
}
}
else if (left->nd_symb == STRING) {
C_loc(left->nd_SLE - 1);
C_loc(left->nd_SLE);
}
else if (tp->arr_elem == word_type) {
C_loc((left_type->tp_size+word_size-1) / word_size - 1);
@ -403,8 +404,10 @@ CodeParameters(param, arg)
if (left_type->tp_fund == T_STRING) {
CodePadString(left, tp->tp_size);
}
else CodePExpr(left);
RangeCheck(left_type, tp);
else {
CodePExpr(left);
RangeCheck(left_type, tp);
}
}
}
@ -413,7 +416,7 @@ CodeStd(nd)
{
register struct node *arg = nd->nd_right;
register struct node *left = 0;
register struct type *tp = 0;
register struct type *tp;
int std = nd->nd_left->nd_def->df_value.df_stdname;
if (arg) {
@ -426,15 +429,11 @@ CodeStd(nd)
case S_ABS:
CodePExpr(left);
if (tp->tp_fund == T_INTEGER) {
if (tp->tp_size == int_size) {
C_cal("_absi");
}
if (tp->tp_size == int_size) C_cal("_absi");
else C_cal("_absl");
}
else if (tp->tp_fund == T_REAL) {
if (tp->tp_size == float_size) {
C_cal("_absf");
}
if (tp->tp_size == float_size) C_cal("_absf");
else C_cal("_absd");
}
C_asp(tp->tp_size);

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

@ -72,7 +72,7 @@ cstbin(expp)
*/
register arith o1 = expp->nd_left->nd_INT;
register arith o2 = expp->nd_right->nd_INT;
register int uns = expp->nd_type != int_type;
register int uns = expp->nd_left->nd_type != int_type;
assert(expp->nd_class == Oper);
assert(expp->nd_left->nd_class == Value);

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

@ -50,13 +50,14 @@ ProcedureHeading(struct def **pdf; int type;)
;
block(struct node **pnd;) :
declaration*
[ { return_occurred = 0; }
[ %persistent
declaration
]*
{ return_occurred = 0; *pnd = 0; }
[ %persistent
BEGIN
StatementSequence(pnd)
|
{ *pnd = 0; }
]
]?
END
;
@ -72,7 +73,7 @@ declaration:
ModuleDeclaration ';'
;
FormalParameters(struct paramlist *ppr; arith *parmaddr; struct type **ptp;):
FormalParameters(struct paramlist **ppr; arith *parmaddr; struct type **ptp;):
'('
[
FPSection(ppr, parmaddr)
@ -160,10 +161,15 @@ enumeration(struct type **ptp;)
} :
'(' IdentList(&EnumList) ')'
{
*ptp = standard_type(T_ENUMERATION, 1, (arith) 1);
*ptp = standard_type(T_ENUMERATION, int_align, int_size);
EnterEnumList(EnumList, *ptp);
if ((*ptp)->enm_ncst > 256) { /* ??? is this reasonable ??? */
error("too many enumeration literals");
if (ufit((*ptp)->enm_ncst-1, 1)) {
(*ptp)->tp_size = 1;
(*ptp)->tp_align = 1;
}
else if (ufit((*ptp)->enm_ncst-1, short_size)) {
(*ptp)->tp_size = short_size;
(*ptp)->tp_align = short_align;
}
}
;
@ -263,7 +269,7 @@ FieldList(struct scope *scope; arith *cnt; int *palign;)
/* Also accept old fashioned Modula-2 syntax, but give a warning.
Sorry for the complicated code.
*/
[ qualident(0, (struct def **) 0, (char *) 0, &nd1)
[ qualident(&nd1)
{ nd = nd1; }
[ ':' qualtype(&tp)
/* This is correct, in both kinds of Modula-2, if
@ -387,7 +393,7 @@ PointerType(struct type **ptp;)
} :
POINTER TO
{ *ptp = construct_type(T_POINTER, NULLTYPE); }
[ %if ( lookup(dot.TOK_IDF, CurrentScope)
[ %if ( lookup(dot.TOK_IDF, CurrentScope, 1)
/* Either a Module or a Type, but in both cases defined
in this scope, so this is the correct identification
*/
@ -422,17 +428,33 @@ PointerType(struct type **ptp;)
qualtype(struct type **ptp;)
{
struct def *df = 0;
register struct node *nd;
struct node *nd1; /* because &nd is illegal */
} :
qualident(D_ISTYPE, &df, "type", (struct node **) 0)
{ if (df && !(*ptp = df->df_type)) {
error("type \"%s\" not declared",
df->df_idf->id_text);
*ptp = error_type;
}
qualident(&nd1)
{ nd = nd1;
*ptp = error_type;
if (ChkDesignator(nd)) {
if (nd->nd_class != Def) {
node_error(nd, "type expected");
}
;
else {
register struct def *df = nd->nd_def;
if (df->df_kind&(D_ISTYPE|D_FORWARD|D_ERROR)) {
if (! df->df_type) {
node_error(nd,"type \"%s\" not (yet) declared", df->df_idf->id_text);
}
else *ptp = df->df_type;
}
else {
node_error(nd,"identifier \"%s\" is not a type", df->df_idf->id_text);
}
}
}
FreeNode(nd);
}
;
ProcedureType(struct type **ptp;)
{

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

@ -90,9 +90,8 @@ struct def { /* list of definitions for a name */
#define is_type(dfx) ((dfx)->df_kind & D_ISTYPE)
char df_flags;
#define D_NOREG 0x01 /* set if it may not reside in a register */
#define D_USED 0x02 /* set if used */
#define D_DEFINED 0x04 /* set if it is assigned a value */
#define D_REFERRED 0x08 /* set if it is referred to */
#define D_USED 0x02 /* set if used (future use ???) */
#define D_DEFINED 0x04 /* set if it is assigned a value (future use ???) */
#define D_VARPAR 0x10 /* set if it is a VAR parameter */
#define D_VALPAR 0x20 /* set if it is a value parameter */
#define D_EXPORTED 0x40 /* set if exported */

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

@ -91,14 +91,14 @@ define(id, scope, kind)
*/
register struct def *df;
df = lookup(id, scope);
df = lookup(id, scope, 1);
if ( /* Already in this scope */
df
|| /* A closed scope, and id defined in the pervasive scope */
(
scopeclosed(scope)
&&
(df = lookup(id, PervasiveScope)))
(df = lookup(id, PervasiveScope, 1)))
) {
switch(df->df_kind) {
case D_HIDDEN:
@ -234,7 +234,7 @@ DeclProc(type, id)
else {
char *name;
df = lookup(id, CurrentScope);
df = lookup(id, CurrentScope, 1);
if (df && df->df_kind == D_PROCHEAD) {
/* C_exp already generated when we saw the definition
in the definition module

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

@ -16,6 +16,7 @@
#include "main.h"
#include "node.h"
#include "type.h"
#include "misc.h"
#ifdef DEBUG
long sys_filesize();
@ -57,7 +58,7 @@ GetDefinitionModule(id, incr)
struct scopelist *vis;
level += incr;
df = lookup(id, GlobalScope);
df = lookup(id, GlobalScope, 1);
if (!df) {
/* Read definition module. Make an exception for SYSTEM.
*/
@ -66,7 +67,7 @@ GetDefinitionModule(id, incr)
}
else {
open_scope(CLOSEDSCOPE);
if (GetFile(id->id_text)) {
if (!is_anon_idf(id) && GetFile(id->id_text)) {
DefModule();
if (level == 1) {
/* The module is directly imported by
@ -90,14 +91,17 @@ GetDefinitionModule(id, incr)
vis = CurrVis;
close_scope(SC_CHKFORW);
}
df = lookup(id, GlobalScope);
df = lookup(id, GlobalScope, 1);
if (! df) {
df = MkDef(id, GlobalScope, D_ERROR);
df->df_type = error_type;
df->mod_vis = CurrVis;
return df;
df->mod_vis = vis;
}
}
else if (df == Defined) {
error("cannot import from currently defined module");
df->df_kind = D_ERROR;
}
assert(df);
level -= incr;
return df;

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

@ -219,7 +219,6 @@ CodeVarDesig(df, ds)
*/
assert(ds->dsg_kind == DSG_INIT);
SetUsed(df);
if (df->var_addrgiven) {
/* the programmer specified an address in the declaration of
the variable. Generate code to push the address.
@ -293,7 +292,6 @@ CodeDesig(nd, ds)
case Def:
df = nd->nd_def;
SetUsed(df);
switch(df->df_kind) {
case D_FIELD:
CodeFieldDesig(df, ds);

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

@ -273,7 +273,7 @@ ForwDef(ids, scope)
*/
register struct def *df;
if (!(df = lookup(ids->nd_IDF, scope))) {
if (!(df = lookup(ids->nd_IDF, scope, 1))) {
df = define(ids->nd_IDF, scope, D_FORWARD);
df->for_node = MkLeaf(Name, &(ids->nd_token));
}
@ -292,9 +292,7 @@ EnterExportList(Idlist, qualified)
register struct def *df, *df1;
for (;idlist; idlist = idlist->next) {
extern struct def *NoImportlookup();
df = NoImportlookup(idlist->nd_IDF, CurrentScope);
df = lookup(idlist->nd_IDF, CurrentScope, 0);
if (!df) {
/* undefined item in export list
@ -332,7 +330,7 @@ EnterExportList(Idlist, qualified)
scope imports it.
*/
df1 = lookup(idlist->nd_IDF,
enclosing(CurrVis)->sc_scope);
enclosing(CurrVis)->sc_scope, 1);
if (df1) {
/* It was already defined in the enclosing
scope. There are two legal possibilities,
@ -402,7 +400,7 @@ EnterFromImportList(Idlist, FromDef, FromId)
for (; idlist; idlist = idlist->next) {
if (forwflag) df = ForwDef(idlist, vis->sc_scope);
else if (! (df = lookup(idlist->nd_IDF, vis->sc_scope))) {
else if (! (df = lookup(idlist->nd_IDF, vis->sc_scope, 1))) {
not_declared("identifier", idlist, " in qualifying module");
df = define(idlist->nd_IDF,vis->sc_scope,D_ERROR);
}
@ -434,7 +432,7 @@ EnterImportList(Idlist, local)
for (; idlist; idlist = idlist->next) {
DoImport(local ?
ForwDef(idlist, sc) :
GetDefinitionModule(idlist->nd_IDF) ,
GetDefinitionModule(idlist->nd_IDF, 1) ,
CurrentScope);
}
FreeNode(Idlist);

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

@ -31,39 +31,13 @@ number(struct node **p;) :
}
;
qualident(int types;
struct def **pdf;
char *str;
struct node **p;
)
qualident(struct node **p;)
{
struct node *nd;
} :
IDENT { nd = MkLeaf(Name, &dot); }
IDENT { *p = MkLeaf(Name, &dot); }
[
selector(&nd)
selector(p)
]*
{ if (types && ChkDesignator(nd)) {
if (nd->nd_class != Def) {
node_error(nd, "%s expected", str);
}
else {
register struct def *df = nd->nd_def;
if ( !((types|D_ERROR) & df->df_kind)) {
if (df->df_kind == D_FORWARD) {
not_declared(str, nd, "");
}
else {
node_error(nd,"identifier \"%s\" is not a %s", df->df_idf->id_text, str);
}
}
if (pdf) *pdf = df;
}
}
if (!p) FreeNode(nd);
else *p = nd;
}
;
selector(struct node **pnd;):
@ -167,7 +141,7 @@ factor(register struct node **p;)
{
struct node *nd;
} :
qualident(0, (struct def **) 0, (char *) 0, p)
qualident(p)
[
designator_tail(p)?
[
@ -231,7 +205,7 @@ element(struct node *nd;)
designator(struct node **pnd;)
:
qualident(0, (struct def **) 0, (char *) 0, pnd)
qualident(pnd)
designator_tail(pnd)?
;

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

@ -15,7 +15,7 @@
#include "misc.h"
struct def *
lookup(id, scope)
lookup(id, scope, import)
register struct idf *id;
struct scope *scope;
{
@ -43,7 +43,7 @@ lookup(id, scope)
df->next = id->id_def;
id->id_def = df;
}
if (df->df_kind == D_IMPORT) {
if (import && df->df_kind == D_IMPORT) {
assert(df->imp_def != 0);
return df->imp_def;
}
@ -51,38 +51,6 @@ 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;
@ -96,7 +64,7 @@ lookfor(id, vis, give_error)
register struct scopelist *sc = vis;
while (sc) {
df = lookup(id->nd_IDF, sc->sc_scope);
df = lookup(id->nd_IDF, sc->sc_scope, 1);
if (df) return df;
sc = nextvisible(sc);
}

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

@ -10,6 +10,13 @@
#include "main.h"
#include "warning.h"
#define MINIDFSIZE 14
#if MINIDFSIZE < 14
You fouled up! MINIDFSIZE has to be at least 14 or the compiler will not
recognize some keywords!
#endif
extern int idfsize;
static int ndirs;
int warning_classes;
@ -72,8 +79,14 @@ DoOption(text)
idfsize = txt2int(&t);
if (*t || idfsize <= 0)
fatal("malformed -M option");
if (idfsize > IDFSIZE)
fatal("maximum identifier length is %d", IDFSIZE);
if (idfsize > IDFSIZE) {
idfsize = IDFSIZE;
warning(W_ORDINARY,"maximum identifier length is %d", IDFSIZE);
}
if (idfsize < MINIDFSIZE) {
warning(W_ORDINARY, "minimum identifier length is %d", MINIDFSIZE);
idfsize = MINIDFSIZE;
}
}
break;
@ -113,6 +126,10 @@ DoOption(text)
if (size != (arith)0) int_size = size;
if (align != 0) int_align = align;
break;
case 's': /* short (subranges) */
if (size != 0) short_size = size;
if (align != 0) short_align = align;
break;
case 'l': /* longint */
if (size != (arith)0) long_size = size;
if (align != 0) long_align = align;

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

@ -133,7 +133,7 @@ DefinitionModule
modules. Issue a warning.
*/
{
node_warning(exportlist, W_ORDINARY, "export list in definition module ignored");
node_warning(exportlist, W_OLDFASHIONED, "export list in definition module ignored");
FreeNode(exportlist);
}
|
@ -183,7 +183,7 @@ definition
ProgramModule
{
struct def *GetDefinitionModule();
extern struct def *GetDefinitionModule();
register struct def *df;
} :
MODULE
@ -210,7 +210,9 @@ ProgramModule
;
Module:
{ open_scope(CLOSEDSCOPE); }
{ open_scope(CLOSEDSCOPE);
warning(W_ORDINARY, "Compiling a definition module");
}
DefinitionModule
{ close_scope(SC_CHKFORW); }
|

7
lang/m2/comp/type.H
View file

@ -103,6 +103,7 @@ extern struct type
extern int
word_align,
short_align,
int_align,
long_align,
float_align,
@ -113,6 +114,7 @@ extern int
extern arith
word_size,
dword_size,
short_size,
int_size,
long_size,
float_size,
@ -149,3 +151,8 @@ struct type
#define BaseType(tpx) ((tpx)->tp_fund == T_SUBRANGE ? (tpx)->next : \
(tpx))
#define IsConstructed(tpx) ((tpx)->tp_fund & T_CONSTRUCTED)
extern long full_mask[];
#define fit(n, i) (((n) + (0x80<<(((i)-1)*8)) & ~full_mask[(i)]) == 0)
#define ufit(n, i) (((n) & ~full_mask[(i)]) == 0)

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

@ -21,6 +21,7 @@
int
word_align = AL_WORD,
short_align = AL_SHORT,
int_align = AL_INT,
long_align = AL_LONG,
float_align = AL_FLOAT,
@ -32,6 +33,7 @@ arith
word_size = SZ_WORD,
dword_size = 2 * SZ_WORD,
int_size = SZ_INT,
short_size = SZ_SHORT,
long_size = SZ_LONG,
float_size = SZ_FLOAT,
double_size = SZ_DOUBLE,
@ -280,6 +282,27 @@ subr_type(lb, ub)
res->sub_ub = ub->nd_INT;
res->tp_size = tp->tp_size;
res->tp_align = tp->tp_align;
if (tp == card_type) {
if (ufit(res->sub_ub, 1)) {
res->tp_size = 1;
res->tp_align = 1;
}
else if (ufit(res->sub_ub, 2)) {
res->tp_size = short_size;
res->tp_align = short_align;
}
}
else if (tp == int_type) {
if (fit(res->sub_lb, 1) && fit(res->sub_ub, 1)) {
res->tp_size = 1;
res->tp_align = 1;
}
else if (fit(res->sub_lb, short_size) &&
fit(res->sub_ub, short_size)) {
res->tp_size = short_size;
res->tp_align = short_align;
}
}
return res;
}

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

@ -636,9 +636,9 @@ DoForInit(nd, left)
nd->nd_class = Name;
nd->nd_symb = IDENT;
if (! ChkVariable(nd) ||
! WalkExpr(left->nd_left) ||
! ChkExpression(left->nd_right)) return 0;
if (!( ChkVariable(nd) &
WalkExpr(left->nd_left) &
ChkExpression(left->nd_right))) return 0;
df = nd->nd_def;
if (df->df_kind == D_FIELD) {
@ -696,17 +696,17 @@ DoAssign(nd, left, right)
*/
struct desig dsl, dsr;
if (! ChkExpression(right) || ! ChkVariable(left)) return;
if (! (ChkExpression(right) & ChkVariable(left))) return;
if (right->nd_symb == STRING) TryToString(right, left->nd_type);
dsr = InitDesig;
CodeExpr(right, &dsr, NO_LABEL, NO_LABEL);
if (! TstAssCompat(left->nd_type, right->nd_type)) {
node_error(nd, "type incompatibility in assignment");
return;
}
CodeExpr(right, &dsr, NO_LABEL, NO_LABEL);
if (complex(right->nd_type)) {
CodeAddress(&dsr);
}