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". /* Read a Modula-2 string, delimited by the character "upto".
*/ */
register int ch; 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 char *p;
register int len;
str->s_length = ISTRSIZE; len = ISTRSIZE;
str->s_str = p = Malloc((unsigned int) ISTRSIZE); str->s_str = p = Malloc((unsigned int) ISTRSIZE);
while (LoadChar(ch), ch != upto) { while (LoadChar(ch), ch != upto) {
if (class(ch) == STNL) { if (class(ch) == STNL) {
@ -95,15 +97,18 @@ GetString(upto)
break; break;
} }
*p++ = ch; *p++ = ch;
if (p - str->s_str == str->s_length) { if (p - str->s_str == len) {
str->s_str = Srealloc(str->s_str, str->s_str = Srealloc(str->s_str,
(unsigned int) str->s_length + RSTRSIZE); (unsigned int) len + RSTRSIZE);
p = str->s_str + str->s_length; p = str->s_str + len;
str->s_length += RSTRSIZE; len += RSTRSIZE;
} }
} }
*p = '\0';
str->s_length = p - str->s_str; 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; return str;
} }
@ -172,7 +177,7 @@ linedirective() {
* Remember the file name * Remember the file name
*/ */
if (!eofseen && strcmp(FileName,buf)) { if (!eofseen && strcmp(FileName,buf)) {
FileName = Salloc(buf,strlen(buf) + 1); FileName = Salloc(buf,(unsigned) strlen(buf) + 1);
} }
} }
if (eofseen) { 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' sh -c 'if $(CC) nmclash.c > /dev/null 2>&1 ; then make Xlint ; else sh Resolve Xlint ; fi'
@rm -f nmclash.o a.out @rm -f nmclash.o a.out
clashes: $(SRC) $(HFILES) longnames: $(SRC) $(HFILES)
sh -c 'if test -f clashes ; then cclash -l7 clashes $? > Xclashes ; mv Xclashes clashes ; else cclash -l7 $? > clashes ; fi' 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 # entry points not to be used directly

2
lang/m2/comp/Parameters
View file

@ -1,6 +1,6 @@
!File: errout.h !File: errout.h
#define ERROUT STDERR /* file pointer for writing messages */ #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. */ on the same input line. */

4
lang/m2/comp/Resolve
View file

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

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

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

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

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

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

@ -50,13 +50,14 @@ ProcedureHeading(struct def **pdf; int type;)
; ;
block(struct node **pnd;) : block(struct node **pnd;) :
declaration* [ %persistent
[ { return_occurred = 0; } declaration
]*
{ return_occurred = 0; *pnd = 0; }
[ %persistent
BEGIN BEGIN
StatementSequence(pnd) StatementSequence(pnd)
| ]?
{ *pnd = 0; }
]
END END
; ;
@ -72,7 +73,7 @@ declaration:
ModuleDeclaration ';' ModuleDeclaration ';'
; ;
FormalParameters(struct paramlist *ppr; arith *parmaddr; struct type **ptp;): FormalParameters(struct paramlist **ppr; arith *parmaddr; struct type **ptp;):
'(' '('
[ [
FPSection(ppr, parmaddr) FPSection(ppr, parmaddr)
@ -160,10 +161,15 @@ enumeration(struct type **ptp;)
} : } :
'(' IdentList(&EnumList) ')' '(' IdentList(&EnumList) ')'
{ {
*ptp = standard_type(T_ENUMERATION, 1, (arith) 1); *ptp = standard_type(T_ENUMERATION, int_align, int_size);
EnterEnumList(EnumList, *ptp); EnterEnumList(EnumList, *ptp);
if ((*ptp)->enm_ncst > 256) { /* ??? is this reasonable ??? */ if (ufit((*ptp)->enm_ncst-1, 1)) {
error("too many enumeration literals"); (*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. /* Also accept old fashioned Modula-2 syntax, but give a warning.
Sorry for the complicated code. Sorry for the complicated code.
*/ */
[ qualident(0, (struct def **) 0, (char *) 0, &nd1) [ qualident(&nd1)
{ nd = nd1; } { nd = nd1; }
[ ':' qualtype(&tp) [ ':' qualtype(&tp)
/* This is correct, in both kinds of Modula-2, if /* This is correct, in both kinds of Modula-2, if
@ -387,7 +393,7 @@ 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, 1)
/* 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
*/ */
@ -422,18 +428,34 @@ PointerType(struct type **ptp;)
qualtype(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) qualident(&nd1)
{ if (df && !(*ptp = df->df_type)) { { nd = nd1;
error("type \"%s\" not declared",
df->df_idf->id_text);
*ptp = error_type; *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;) ProcedureType(struct type **ptp;)
{ {
struct paramlist *pr = 0; struct paramlist *pr = 0;

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) #define is_type(dfx) ((dfx)->df_kind & D_ISTYPE)
char df_flags; char df_flags;
#define D_NOREG 0x01 /* set if it may not reside in a register */ #define D_NOREG 0x01 /* set if it may not reside in a register */
#define D_USED 0x02 /* set if used */ #define D_USED 0x02 /* set if used (future use ???) */
#define D_DEFINED 0x04 /* set if it is assigned a value */ #define D_DEFINED 0x04 /* set if it is assigned a value (future use ???) */
#define D_REFERRED 0x08 /* set if it is referred to */
#define D_VARPAR 0x10 /* set if it is a VAR parameter */ #define D_VARPAR 0x10 /* set if it is a VAR parameter */
#define D_VALPAR 0x20 /* set if it is a value parameter */ #define D_VALPAR 0x20 /* set if it is a value parameter */
#define D_EXPORTED 0x40 /* set if exported */ #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; register struct def *df;
df = lookup(id, scope); df = lookup(id, scope, 1);
if ( /* Already in this scope */ if ( /* Already in this scope */
df df
|| /* A closed scope, and id defined in the pervasive scope */ || /* A closed scope, and id defined in the pervasive scope */
( (
scopeclosed(scope) scopeclosed(scope)
&& &&
(df = lookup(id, PervasiveScope))) (df = lookup(id, PervasiveScope, 1)))
) { ) {
switch(df->df_kind) { switch(df->df_kind) {
case D_HIDDEN: case D_HIDDEN:
@ -234,7 +234,7 @@ DeclProc(type, id)
else { else {
char *name; char *name;
df = lookup(id, CurrentScope); df = lookup(id, CurrentScope, 1);
if (df && df->df_kind == D_PROCHEAD) { if (df && df->df_kind == D_PROCHEAD) {
/* C_exp already generated when we saw the definition /* C_exp already generated when we saw the definition
in the definition module in the definition module

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

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

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

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

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

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

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

@ -31,39 +31,13 @@ number(struct node **p;) :
} }
; ;
qualident(int types; qualident(struct node **p;)
struct def **pdf;
char *str;
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;): selector(struct node **pnd;):
@ -167,7 +141,7 @@ factor(register struct node **p;)
{ {
struct node *nd; struct node *nd;
} : } :
qualident(0, (struct def **) 0, (char *) 0, p) qualident(p)
[ [
designator_tail(p)? designator_tail(p)?
[ [
@ -231,7 +205,7 @@ element(struct node *nd;)
designator(struct node **pnd;) designator(struct node **pnd;)
: :
qualident(0, (struct def **) 0, (char *) 0, pnd) qualident(pnd)
designator_tail(pnd)? designator_tail(pnd)?
; ;

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

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

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

@ -10,6 +10,13 @@
#include "main.h" #include "main.h"
#include "warning.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; extern int idfsize;
static int ndirs; static int ndirs;
int warning_classes; int warning_classes;
@ -72,8 +79,14 @@ DoOption(text)
idfsize = txt2int(&t); idfsize = txt2int(&t);
if (*t || idfsize <= 0) if (*t || idfsize <= 0)
fatal("malformed -M option"); fatal("malformed -M option");
if (idfsize > IDFSIZE) if (idfsize > IDFSIZE) {
fatal("maximum identifier length is %d", 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; break;
@ -113,6 +126,10 @@ DoOption(text)
if (size != (arith)0) int_size = size; if (size != (arith)0) int_size = size;
if (align != 0) int_align = align; if (align != 0) int_align = align;
break; break;
case 's': /* short (subranges) */
if (size != 0) short_size = size;
if (align != 0) short_align = align;
break;
case 'l': /* longint */ case 'l': /* longint */
if (size != (arith)0) long_size = size; if (size != (arith)0) long_size = size;
if (align != 0) long_align = align; if (align != 0) long_align = align;

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

@ -133,7 +133,7 @@ DefinitionModule
modules. Issue a warning. 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); FreeNode(exportlist);
} }
| |
@ -183,7 +183,7 @@ definition
ProgramModule ProgramModule
{ {
struct def *GetDefinitionModule(); extern struct def *GetDefinitionModule();
register struct def *df; register struct def *df;
} : } :
MODULE MODULE
@ -210,7 +210,9 @@ ProgramModule
; ;
Module: Module:
{ open_scope(CLOSEDSCOPE); } { open_scope(CLOSEDSCOPE);
warning(W_ORDINARY, "Compiling a definition module");
}
DefinitionModule DefinitionModule
{ close_scope(SC_CHKFORW); } { close_scope(SC_CHKFORW); }
| |

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

@ -103,6 +103,7 @@ extern struct type
extern int extern int
word_align, word_align,
short_align,
int_align, int_align,
long_align, long_align,
float_align, float_align,
@ -113,6 +114,7 @@ extern int
extern arith extern arith
word_size, word_size,
dword_size, dword_size,
short_size,
int_size, int_size,
long_size, long_size,
float_size, float_size,
@ -149,3 +151,8 @@ struct type
#define BaseType(tpx) ((tpx)->tp_fund == T_SUBRANGE ? (tpx)->next : \ #define BaseType(tpx) ((tpx)->tp_fund == T_SUBRANGE ? (tpx)->next : \
(tpx)) (tpx))
#define IsConstructed(tpx) ((tpx)->tp_fund & T_CONSTRUCTED) #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 int
word_align = AL_WORD, word_align = AL_WORD,
short_align = AL_SHORT,
int_align = AL_INT, int_align = AL_INT,
long_align = AL_LONG, long_align = AL_LONG,
float_align = AL_FLOAT, float_align = AL_FLOAT,
@ -32,6 +33,7 @@ arith
word_size = SZ_WORD, word_size = SZ_WORD,
dword_size = 2 * SZ_WORD, dword_size = 2 * SZ_WORD,
int_size = SZ_INT, int_size = SZ_INT,
short_size = SZ_SHORT,
long_size = SZ_LONG, long_size = SZ_LONG,
float_size = SZ_FLOAT, float_size = SZ_FLOAT,
double_size = SZ_DOUBLE, double_size = SZ_DOUBLE,
@ -280,6 +282,27 @@ subr_type(lb, ub)
res->sub_ub = ub->nd_INT; res->sub_ub = ub->nd_INT;
res->tp_size = tp->tp_size; res->tp_size = tp->tp_size;
res->tp_align = tp->tp_align; 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; return res;
} }

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

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