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

newer version

Browse source
This commit is contained in:
ceriel 1986-04-11 11:57:19 +00:00
parent ba47f9fe7c
commit 64a9f1e5d7
12 changed files with 379 additions and 107 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

10
lang/m2/comp/Makefile
View file

@ -82,16 +82,16 @@ symbol2str.o: Lpars.h
tokenname.o: Lpars.h idf.h tokenname.h tokenname.o: Lpars.h idf.h tokenname.h
idf.o: idf.h idf.o: idf.h
input.o: f_info.h input.h input.o: f_info.h input.h
type.o: LLlex.h Lpars.h const.h debug.h def.h def_sizes.h idf.h node.h type.h type.o: LLlex.h const.h debug.h def.h def_sizes.h idf.h node.h type.h
def.o: LLlex.h Lpars.h debug.h def.h idf.h main.h node.h scope.h type.h def.o: LLlex.h 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 scope.o: LLlex.h debug.h def.h idf.h node.h scope.h type.h
misc.o: LLlex.h f_info.h idf.h misc.h node.h misc.o: LLlex.h f_info.h idf.h misc.h node.h
enter.o: LLlex.h def.h idf.h node.h scope.h type.h enter.o: LLlex.h def.h idf.h node.h scope.h type.h
defmodule.o: LLlex.h debug.h def.h f_info.h idf.h input.h scope.h defmodule.o: LLlex.h debug.h def.h f_info.h idf.h input.h scope.h
typequiv.o: Lpars.h def.h type.h typequiv.o: def.h type.h
node.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 def_sizes.h idf.h node.h type.h cstoper.o: LLlex.h Lpars.h def_sizes.h idf.h node.h standards.h type.h
chk_expr.o: LLlex.h Lpars.h const.h def.h idf.h node.h scope.h standards.h type.h chk_expr.o: LLlex.h Lpars.h const.h debug.h def.h idf.h node.h scope.h standards.h type.h
tokenfile.o: Lpars.h tokenfile.o: Lpars.h
program.o: LLlex.h Lpars.h debug.h def.h idf.h main.h node.h scope.h type.h program.o: LLlex.h Lpars.h debug.h def.h idf.h main.h node.h scope.h type.h
declar.o: LLlex.h Lpars.h def.h idf.h misc.h node.h scope.h type.h declar.o: LLlex.h Lpars.h def.h idf.h misc.h node.h scope.h type.h

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

@ -17,6 +17,7 @@ static char *RcsId = "$Header$";
#include "scope.h" #include "scope.h"
#include "const.h" #include "const.h"
#include "standards.h" #include "standards.h"
#include "debug.h"
int int
chk_expr(expp) chk_expr(expp)
@ -199,7 +200,7 @@ getarg(argp, bases)
struct type *tp; struct type *tp;
if (!argp->nd_right) { if (!argp->nd_right) {
node_error(argp, "Too few arguments supplied"); node_error(argp, "too few arguments supplied");
return 0; return 0;
} }
argp = argp->nd_right; argp = argp->nd_right;
@ -218,7 +219,7 @@ getname(argp, kinds)
struct node *argp; struct node *argp;
{ {
if (!argp->nd_right) { if (!argp->nd_right) {
node_error(argp, "Too few arguments supplied"); node_error(argp, "too few arguments supplied");
return 0; return 0;
} }
argp = argp->nd_right; argp = argp->nd_right;
@ -235,67 +236,84 @@ int
chk_call(expp) chk_call(expp)
register struct node *expp; register struct node *expp;
{ {
register struct type *tp; /* Check something that looks like a procedure or function call.
Of course this does not have to be a call at all.
it may also be a cast or a standard procedure call.
*/
register struct node *left; register struct node *left;
register struct node *arg; register struct node *arg;
expp->nd_type = error_type; expp->nd_type = error_type;
(void) findname(expp->nd_left); (void) findname(expp->nd_left); /* parser made sure it is a name */
left = expp->nd_left; left = expp->nd_left;
tp = left->nd_type;
if (tp == error_type) return 0; if (left->nd_type == error_type) return 0;
if (left->nd_class == Def && if (left->nd_class == Def &&
(left->nd_def->df_kind & (D_HTYPE|D_TYPE|D_HIDDEN))) { (left->nd_def->df_kind & (D_HTYPE|D_TYPE|D_HIDDEN))) {
/* A type cast. This is of course not portable. /* A type cast. This is of course not portable.
No runtime action. Remove it. No runtime action. Remove it.
*/ */
arg = expp->nd_right; arg = expp->nd_right;
if (!arg || arg->nd_right) { if ((! arg) || arg->nd_right) {
node_error(expp, "Only one parameter expected in type cast"); node_error(expp, "Only one parameter expected in type cast");
return 0; return 0;
} }
if (! chk_expr(arg->nd_left)) return 0; arg = arg->nd_left;
if (arg->nd_left->nd_type->tp_size != if (! chk_expr(arg)) return 0;
left->nd_type->tp_size) { if (arg->nd_type->tp_size != left->nd_type->tp_size) {
node_error(expp, "Size of type in type cast does not match size of operand"); node_error(expp, "Size of type in type cast does not match size of operand");
return 0; return 0;
} }
arg->nd_left->nd_type = left->nd_type; arg->nd_type = left->nd_type;
FreeNode(expp->nd_left); FreeNode(expp->nd_left);
*expp = *(arg->nd_left); *expp = *(arg->nd_left);
arg->nd_left->nd_left = 0; arg->nd_left = 0;
arg->nd_left->nd_right = 0; arg->nd_right = 0;
FreeNode(arg); FreeNode(arg);
return 1; return 1;
} }
if ((left->nd_class == Def && left->nd_def->df_kind == D_PROCEDURE) || if ((left->nd_class == Def && left->nd_def->df_kind == D_PROCEDURE) ||
tp->tp_fund == T_PROCEDURE) { left->nd_type->tp_fund == T_PROCEDURE) {
/* A procedure call. it may also be a call to a /* A procedure call. it may also be a call to a
standard procedure standard procedure
*/ */
arg = expp; arg = expp;
if (tp == std_type) { if (left->nd_type == std_type) {
/* A standard procedure
*/
assert(left->nd_class == Def); assert(left->nd_class == Def);
DO_DEBUG(3, debug("Standard name \"%s\", %d",
left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname));
switch(left->nd_def->df_value.df_stdname) { switch(left->nd_def->df_value.df_stdname) {
case S_ABS: case S_ABS:
arg = getarg(arg, T_INTEGER|T_CARDINAL|T_REAL); arg = getarg(arg, T_NUMERIC);
if (! arg) return 0; if (! arg) return 0;
expp->nd_type = arg->nd_left->nd_type; left = arg->nd_left;
expp->nd_type = left->nd_type;
if (left->nd_class == Value) {
cstcall(expp, S_ABS);
}
break; break;
case S_CAP: case S_CAP:
arg = getarg(arg, T_CHAR); arg = getarg(arg, T_CHAR);
expp->nd_type = char_type; expp->nd_type = char_type;
if (!arg) return 0; if (!arg) return 0;
left = arg->nd_left;
if (left->nd_class == Value) {
cstcall(expp, S_CAP);
}
break; break;
case S_CHR: case S_CHR:
arg = getarg(arg, T_INTEGER|T_CARDINAL); arg = getarg(arg, T_INTORCARD);
expp->nd_type = char_type; expp->nd_type = char_type;
if (!arg) return 0; if (!arg) return 0;
if (arg->nd_left->nd_class == Value) {
cstcall(expp, S_CHR);
}
break; break;
case S_FLOAT: case S_FLOAT:
arg = getarg(arg, T_CARDINAL|T_INTEGER); arg = getarg(arg, T_INTORCARD);
expp->nd_type = real_type; expp->nd_type = real_type;
if (!arg) return 0; if (!arg) return 0;
break; break;
@ -303,50 +321,71 @@ node_error(expp, "Size of type in type cast does not match size of operand");
arg = getarg(arg, T_ARRAY); arg = getarg(arg, T_ARRAY);
if (!arg) return 0; if (!arg) return 0;
expp->nd_type = arg->nd_left->nd_type->next; expp->nd_type = arg->nd_left->nd_type->next;
if (!expp->nd_type) expp->nd_type = int_type; if (!expp->nd_type) {
/* A dynamic array has no explicit
index type
*/
expp->nd_type = int_type;
}
else cstcall(expp, S_MAX);
break; break;
case S_MAX: case S_MAX:
case S_MIN: case S_MIN:
arg = getarg(arg, T_ENUMERATION|T_CHAR|T_INTEGER|T_CARDINAL); arg = getarg(arg, T_DISCRETE);
if (!arg) return 0; if (!arg) return 0;
expp->nd_type = arg->nd_left->nd_type; expp->nd_type = arg->nd_left->nd_type;
cstcall(expp,left->nd_def->df_value.df_stdname);
break; break;
case S_ODD: case S_ODD:
arg = getarg(arg, T_INTEGER|T_CARDINAL); arg = getarg(arg, T_INTORCARD);
if (!arg) return 0; if (!arg) return 0;
expp->nd_type = bool_type; expp->nd_type = bool_type;
if (arg->nd_left->nd_class == Value) {
cstcall(expp, S_ODD);
}
break; break;
case S_ORD: case S_ORD:
arg = getarg(arg, T_ENUMERATION|T_CHAR|T_INTEGER|T_CARDINAL); arg = getarg(arg, T_DISCRETE);
if (!arg) return 0; if (!arg) return 0;
expp->nd_type = card_type; expp->nd_type = card_type;
if (arg->nd_left->nd_class == Value) {
cstcall(expp, S_ORD);
}
break; break;
case S_TSIZE: /* ??? */ case S_TSIZE: /* ??? */
case S_SIZE: case S_SIZE:
arg = getname(arg, D_FIELD|D_VARIABLE|D_TYPE|D_HIDDEN|D_HTYPE); arg = getname(arg, D_FIELD|D_VARIABLE|D_TYPE|D_HIDDEN|D_HTYPE);
expp->nd_type = intorcard_type; expp->nd_type = intorcard_type;
if (!arg) return 0; if (!arg) return 0;
cstcall(expp, S_SIZE);
break; break;
case S_TRUNC: case S_TRUNC:
arg = getarg(arg, T_REAL); arg = getarg(arg, T_REAL);
if (!arg) return 0; if (!arg) return 0;
expp->nd_type = card_type; expp->nd_type = card_type;
break; break;
case S_VAL: case S_VAL: {
struct type *tp;
arg = getname(arg, D_HIDDEN|D_HTYPE|D_TYPE); arg = getname(arg, D_HIDDEN|D_HTYPE|D_TYPE);
if (!arg) return 0; if (!arg) return 0;
tp = arg->nd_left->nd_def->df_type; tp = arg->nd_left->nd_def->df_type;
if (tp->tp_fund == T_SUBRANGE) tp = tp->next; if (tp->tp_fund == T_SUBRANGE) tp = tp->next;
if (!(tp->tp_fund & (T_ENUMERATION|T_CHAR|T_INTEGER|T_CARDINAL))) { if (!(tp->tp_fund & T_DISCRETE)) {
node_error(arg, "unexpected type"); node_error(arg, "unexpected type");
return 0; return 0;
} }
expp->nd_type = arg->nd_left->nd_def->df_type; expp->nd_type = arg->nd_left->nd_def->df_type;
FreeNode(arg->nd_left); expp->nd_right = arg->nd_right;
arg->nd_left = 0; arg->nd_right = 0;
arg = getarg(arg, T_INTEGER|T_CARDINAL); FreeNode(arg);
arg = getarg(expp, T_INTORCARD);
if (!arg) return 0; if (!arg) return 0;
if (arg->nd_left->nd_class == Value) {
cstcall(expp, S_VAL);
}
break; break;
}
case S_ADR: case S_ADR:
arg = getname(arg, D_VARIABLE|D_FIELD|D_PROCEDURE); arg = getname(arg, D_VARIABLE|D_FIELD|D_PROCEDURE);
expp->nd_type = address_type; expp->nd_type = address_type;
@ -358,7 +397,7 @@ node_error(expp, "Size of type in type cast does not match size of operand");
arg = getname(arg, D_VARIABLE|D_FIELD); arg = getname(arg, D_VARIABLE|D_FIELD);
if (!arg) return 0; if (!arg) return 0;
if (arg->nd_right) { if (arg->nd_right) {
arg = getarg(arg, T_INTEGER|T_CARDINAL); arg = getarg(arg, T_INTORCARD);
if (!arg) return 0; if (!arg) return 0;
} }
break; break;
@ -366,7 +405,9 @@ node_error(expp, "Size of type in type cast does not match size of operand");
expp->nd_type = 0; expp->nd_type = 0;
break; break;
case S_EXCL: case S_EXCL:
case S_INCL: case S_INCL: {
struct type *tp;
expp->nd_type = 0; expp->nd_type = 0;
arg = getname(arg, D_VARIABLE|D_FIELD); arg = getname(arg, D_VARIABLE|D_FIELD);
if (!arg) return 0; if (!arg) return 0;
@ -375,25 +416,26 @@ node_error(expp, "Size of type in type cast does not match size of operand");
node_error(arg, "EXCL and INCL expect a SET parameter"); node_error(arg, "EXCL and INCL expect a SET parameter");
return 0; return 0;
} }
arg = getarg(arg, T_INTEGER|T_CARDINAL|T_CHAR|T_ENUMERATION); arg = getarg(arg, T_DISCRETE);
if (!arg) return 0; if (!arg) return 0;
if (!TstCompat(tp->next, arg->nd_left->nd_type)) { if (!TstCompat(tp->next, arg->nd_left->nd_type)) {
node_error(arg, "Unexpected type"); node_error(arg, "Unexpected type");
return 0; return 0;
} }
break; break;
}
default: default:
assert(0); assert(0);
} }
if (arg->nd_right) { if (arg->nd_right) {
node_error(arg->nd_right, node_error(arg->nd_right,
"Too many parameters supplied"); "too many parameters supplied");
return 0; return 0;
} }
FreeNode(expp->nd_left);
expp->nd_left = 0;
return 1; return 1;
} }
/* Here, we have found a real procedure call
*/
return 1; return 1;
} }
node_error(expp->nd_left, "procedure, type, or function expected"); node_error(expp->nd_left, "procedure, type, or function expected");
@ -527,17 +569,22 @@ node_error(expp, "RHS of IN operator not a SET type");
node_error(expp, "IN operator: type of LHS not compatible with element type of RHS"); node_error(expp, "IN operator: type of LHS not compatible with element type of RHS");
return 0; return 0;
} }
if (expp->nd_left->nd_class == Value &&
expp->nd_right->nd_class == Set) {
cstset(expp);
}
return 1; return 1;
} }
if (expp->nd_symb == '[') { if (expp->nd_symb == '[') {
/* Handle ARRAY selection specially too! */ /* Handle ARRAY selection specially too! */
if (tpl->tp_fund != T_ARRAY) { if (tpl->tp_fund != T_ARRAY) {
node_error(expp, "array index not belonging to an ARRAY"); node_error(expp,
"array index not belonging to an ARRAY");
return 0; return 0;
} }
if (!TstCompat(tpl->next, tpr)) { if (!TstCompat(tpl->next, tpr)) {
node_error(expp, "incompatible index type"); node_error(expp, "incompatible index type");
return 0; return 0;
} }
expp->nd_type = tpl->arr_elem; expp->nd_type = tpl->arr_elem;
@ -548,7 +595,9 @@ node_error(expp, "incompatible index type");
expp->nd_type = tpl; expp->nd_type = tpl;
if (!TstCompat(tpl, tpr)) { if (!TstCompat(tpl, tpr)) {
node_error(expp, "Incompatible types for operator \"%s\"", symbol2str(expp->nd_symb)); node_error(expp,
"Incompatible types for operator \"%s\"",
symbol2str(expp->nd_symb));
return 0; return 0;
} }
@ -559,12 +608,18 @@ node_error(expp, "Incompatible types for operator \"%s\"", symbol2str(expp->nd_s
switch(tpl->tp_fund) { switch(tpl->tp_fund) {
case T_INTEGER: case T_INTEGER:
case T_CARDINAL: case T_CARDINAL:
case T_SET: case T_INTORCARD:
if (expp->nd_left->nd_class == Value && if (expp->nd_left->nd_class == Value &&
expp->nd_right->nd_class == Value) { expp->nd_right->nd_class == Value) {
cstbin(expp); cstbin(expp);
} }
return 1; return 1;
case T_SET:
if (expp->nd_left->nd_class == Set &&
expp->nd_right->nd_class == Set) {
cstset(expp);
}
/* Fall through */
case T_REAL: case T_REAL:
return 1; return 1;
} }
@ -572,20 +627,18 @@ node_error(expp, "Incompatible types for operator \"%s\"", symbol2str(expp->nd_s
case '/': case '/':
switch(tpl->tp_fund) { switch(tpl->tp_fund) {
case T_SET: case T_SET:
if (expp->nd_left->nd_class == Value && if (expp->nd_left->nd_class == Set &&
expp->nd_right->nd_class == Value) { expp->nd_right->nd_class == Set) {
cstbin(expp); cstset(expp);
} }
return 1; /* Fall through */
case T_REAL: case T_REAL:
return 1; return 1;
} }
break; break;
case DIV: case DIV:
case MOD: case MOD:
switch(tpl->tp_fund) { if (tpl->tp_fund & T_INTORCARD) {
case T_INTEGER:
case T_CARDINAL:
if (expp->nd_left->nd_class == Value && if (expp->nd_left->nd_class == Value &&
expp->nd_right->nd_class == Value) { expp->nd_right->nd_class == Value) {
cstbin(expp); cstbin(expp);
@ -617,13 +670,14 @@ node_error(expp, "Incompatible types for operator \"%s\"", symbol2str(expp->nd_s
} }
if (expp->nd_left->nd_class == Set && if (expp->nd_left->nd_class == Set &&
expp->nd_right->nd_class == Set) { expp->nd_right->nd_class == Set) {
cstbin(expp); cstset(expp);
} }
return 1; return 1;
case T_INTEGER: case T_INTEGER:
case T_CARDINAL: case T_CARDINAL:
case T_ENUMERATION: /* includes boolean */ case T_ENUMERATION: /* includes boolean */
case T_CHAR: case T_CHAR:
case T_INTORCARD:
if (expp->nd_left->nd_class == Value && if (expp->nd_left->nd_class == Value &&
expp->nd_right->nd_class == Value) { expp->nd_right->nd_class == Value) {
cstbin(expp); cstbin(expp);
@ -666,10 +720,7 @@ chk_uoper(expp)
switch(expp->nd_symb) { switch(expp->nd_symb) {
case '+': case '+':
switch(tpr->tp_fund) { if (tpr->tp_fund & T_NUMERIC) {
case T_INTEGER:
case T_REAL:
case T_CARDINAL:
expp->nd_token = expp->nd_right->nd_token; expp->nd_token = expp->nd_right->nd_token;
FreeNode(expp->nd_right); FreeNode(expp->nd_right);
expp->nd_right = 0; expp->nd_right = 0;
@ -677,13 +728,13 @@ chk_uoper(expp)
} }
break; break;
case '-': case '-':
switch(tpr->tp_fund) { if (tpr->tp_fund & T_INTORCARD) {
case T_INTEGER:
if (expp->nd_right->nd_class == Value) { if (expp->nd_right->nd_class == Value) {
cstunary(expp); cstunary(expp);
} }
return 1; return 1;
case T_REAL: }
else if (tpr->tp_fund == T_REAL) {
if (expp->nd_right->nd_class == Value) { if (expp->nd_right->nd_class == Value) {
expp->nd_token = expp->nd_right->nd_token; expp->nd_token = expp->nd_right->nd_token;
if (*(expp->nd_REL) == '-') { if (*(expp->nd_REL) == '-') {
@ -711,7 +762,7 @@ chk_uoper(expp)
default: default:
assert(0); assert(0);
} }
node_error(expp, "Illegal operand for unary operator \"%s\"", node_error(expp, "illegal operand for unary operator \"%s\"",
symbol2str(expp->nd_symb)); symbol2str(expp->nd_symb));
return 0; return 0;
} }

1
lang/m2/comp/const.h
View file

@ -9,4 +9,5 @@ extern int
extern arith extern arith
max_int, /* maximum integer on target machine */ max_int, /* maximum integer on target machine */
max_unsigned, /* maximum unsigned on target machine */ max_unsigned, /* maximum unsigned on target machine */
max_longint, /* maximum longint on target machine */
wrd_bits; /* Number of bits in a word */ wrd_bits; /* Number of bits in a word */

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

@ -11,6 +11,7 @@ static char *RcsId = "$Header$";
#include "LLlex.h" #include "LLlex.h"
#include "node.h" #include "node.h"
#include "Lpars.h" #include "Lpars.h"
#include "standards.h"
long mach_long_sign; /* sign bit of the machine long */ long mach_long_sign; /* sign bit of the machine long */
int mach_long_size; /* size of long on this machine == sizeof(long) */ int mach_long_size; /* size of long on this machine == sizeof(long) */
@ -60,10 +61,7 @@ cstbin(expp)
int uns = expp->nd_type != int_type; int uns = expp->nd_type != int_type;
assert(expp->nd_class == Oper); assert(expp->nd_class == Oper);
if (expp->nd_right->nd_type->tp_fund == T_SET) { assert(expp->nd_left->nd_class == Value && expp->nd_right->nd_class == Value);
cstset(expp);
return;
}
switch (expp->nd_symb) { switch (expp->nd_symb) {
case '*': case '*':
o1 *= o2; o1 *= o2;
@ -288,6 +286,108 @@ cstset(expp)
expp->nd_left = expp->nd_right = 0; expp->nd_left = expp->nd_right = 0;
} }
cstcall(expp, call)
register struct node *expp;
{
/* a standard procedure call is found that can be evaluated
compile time, so do so.
*/
register struct node *expr = 0;
assert(expp->nd_class == Call);
if (expp->nd_right) {
expr = expp->nd_right->nd_left;
expp->nd_right->nd_left = 0;
FreeNode(expp->nd_right);
}
expp->nd_class = Value;
switch(call) {
case S_ABS:
if (expr->nd_type->tp_fund == T_REAL) {
expp->nd_symb = REAL;
expp->nd_REL = expr->nd_REL;
if (*(expr->nd_REL) == '-') (expp->nd_REL)++;
break;
}
if (expr->nd_INT < 0) expp->nd_INT = - expr->nd_INT;
else expp->nd_INT = expr->nd_INT;
cut_size(expp);
break;
case S_CAP:
if (expr->nd_INT >= 'a' && expr->nd_INT <= 'z') {
expp->nd_INT = expr->nd_INT + ('A' - 'a');
}
else expp->nd_INT = expr->nd_INT;
cut_size(expp);
break;
case S_CHR:
expp->nd_INT = expr->nd_INT;
cut_size(expp);
break;
case S_MAX:
if (expp->nd_type == int_type) {
expp->nd_INT = max_int;
}
else if (expp->nd_type == longint_type) {
expp->nd_INT = max_longint;
}
else if (expp->nd_type == card_type) {
expp->nd_INT = max_unsigned;
}
else if (expp->nd_type->tp_fund == T_SUBRANGE) {
expp->nd_INT = expp->nd_type->sub_ub;
}
else expp->nd_INT = expp->nd_type->enm_ncst - 1;
break;
case S_MIN:
if (expp->nd_type == int_type) {
expp->nd_INT = (-max_int) - 1;
}
else if (expp->nd_type == longint_type) {
expp->nd_INT = (-max_longint) - 1;
}
else if (expp->nd_type->tp_fund == T_SUBRANGE) {
expp->nd_INT = expp->nd_type->sub_lb;
}
else expp->nd_INT = 0;
break;
case S_ODD:
expp->nd_INT = (expr->nd_INT & 1);
break;
case S_ORD:
expp->nd_INT = expr->nd_INT;
cut_size(expp);
break;
case S_SIZE:
expp->nd_INT = align(expr->nd_type->tp_size, wrd_size)/wrd_size;
break;
case S_VAL:
expp->nd_INT = expr->nd_INT;
if ( /* Check overflow of subranges or enumerations */
( expp->nd_type->tp_fund == T_SUBRANGE
&&
( expp->nd_INT < expp->nd_type->sub_lb
|| expp->nd_INT > expp->nd_type->sub_ub
)
)
||
( expp->nd_type->tp_fund == T_ENUMERATION
&&
( expp->nd_INT < 0
|| expp->nd_INT >= expp->nd_type->enm_ncst
)
)
) node_warning(expp,"overflow in constant expression");
else cut_size(expp);
break;
default:
assert(0);
}
FreeNode(expr);
FreeNode(expp->nd_left);
expp->nd_right = expp->nd_left = 0;
}
cut_size(expr) cut_size(expr)
register struct node *expr; register struct node *expr;
{ {
@ -295,10 +395,13 @@ cut_size(expr)
conform to the size of the type of the expression. conform to the size of the type of the expression.
*/ */
arith o1 = expr->nd_INT; arith o1 = expr->nd_INT;
int uns = expr->nd_type == card_type || expr->nd_type == intorcard_type; struct type *tp = expr->nd_type;
int size = expr->nd_type->tp_size; int uns;
int size = tp->tp_size;
assert(expr->nd_class == Value); assert(expr->nd_class == Value);
if (tp->tp_fund == T_SUBRANGE) tp = tp->next;
uns = (tp->tp_fund & (T_CARDINAL|T_CHAR));
if (uns) { if (uns) {
if (o1 & ~full_mask[size]) { if (o1 & ~full_mask[size]) {
node_warning(expr, node_warning(expr,
@ -332,11 +435,12 @@ init_cst()
} }
mach_long_size = i; mach_long_size = i;
mach_long_sign = 1 << (mach_long_size * 8 - 1); mach_long_sign = 1 << (mach_long_size * 8 - 1);
if (int_size > mach_long_size) { if (lint_size > mach_long_size) {
fatal("sizeof (long) insufficient on this machine"); fatal("sizeof (long) insufficient on this machine");
} }
max_int = full_mask[int_size] & ~(1 << (int_size * 8 - 1)); max_int = full_mask[int_size] & ~(1 << (int_size * 8 - 1));
max_unsigned = full_mask[int_size]; max_unsigned = full_mask[int_size];
max_longint = full_mask[lint_size] & ~(1 << (lint_size * 8 - 1));
wrd_bits = 8 * wrd_size; wrd_bits = 8 * wrd_size;
} }

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

@ -30,7 +30,7 @@ ProcedureDeclaration
ProcedureHeading(struct def **pdf; int type;) ProcedureHeading(struct def **pdf; int type;)
{ {
struct type *tp; struct type *tp = 0;
struct type *tp1 = 0; struct type *tp1 = 0;
struct paramlist *params = 0; struct paramlist *params = 0;
register struct def *df; register struct def *df;
@ -97,7 +97,7 @@ FormalParameters(int doparams; struct paramlist **pr; struct type **tp;)
]? ]?
')' ')'
{ *tp = 0; } { *tp = 0; }
[ ':' qualident(D_TYPE | D_HTYPE, &df, "type", (struct node **) 0) [ ':' qualident(D_TYPE|D_HTYPE|D_HIDDEN, &df, "type", (struct node **) 0)
{ *tp = df->df_type; } { *tp = df->df_type; }
]? ]?
; ;
@ -135,7 +135,7 @@ FormalType(struct type **tp;)
} : } :
[ ARRAY OF { ARRAYflag = 1; } [ ARRAY OF { ARRAYflag = 1; }
]? ]?
qualident(D_TYPE | D_HTYPE, &df, "type", (struct node **) 0) qualident(D_TYPE|D_HTYPE|D_HIDDEN, &df, "type", (struct node **) 0)
{ if (ARRAYflag) { { if (ARRAYflag) {
*tp = construct_type(T_ARRAY, NULLTYPE); *tp = construct_type(T_ARRAY, NULLTYPE);
(*tp)->arr_elem = df->df_type; (*tp)->arr_elem = df->df_type;
@ -183,7 +183,7 @@ SimpleType(struct type **ptp;)
{ {
struct def *df; struct def *df;
} : } :
qualident(D_TYPE | D_HTYPE, &df, "type", (struct node **) 0) qualident(D_TYPE|D_HTYPE|D_HIDDEN, &df, "type", (struct node **) 0)
[ [
/* nothing */ /* nothing */
{ *ptp = df->df_type; } { *ptp = df->df_type; }
@ -293,6 +293,7 @@ FieldList(struct scope *scope;)
struct idf *id; struct idf *id;
struct def *df, *df1; struct def *df, *df1;
struct type *tp; struct type *tp;
struct node *nd;
} : } :
[ [
IdentList(&FldList) ':' type(&tp) IdentList(&FldList) ':' type(&tp)
@ -301,13 +302,51 @@ FieldList(struct scope *scope;)
} }
| |
CASE CASE
[ /* Also accept old fashioned Modula-2 syntax, but give a warning
IDENT { id = dot.TOK_IDF; } */
[ qualident(0, &df, (char *) 0, &nd)
[ /* This is good, in both kinds of Modula-2, if
the first qualident is a single identifier.
*/
{
if (nd->nd_class != Name) {
error("illegal variant tag");
id = gen_anon_idf();
}
else id = nd->nd_IDF;
}
':' qualident(D_TYPE|D_HTYPE|D_HIDDEN,
&df, "type", (struct node **) 0)
|
/* Old fashioned! the first qualident now represents
the type
*/
{
warning("Old fashioned Modula-2 syntax!");
id = gen_anon_idf();
findname(nd);
assert(nd->nd_class == Def);
df = nd->nd_def;
if (!(df->df_kind &
(D_ERROR|D_TYPE|D_HTYPE|D_HIDDEN))) {
error("identifier \"%s\" is not a type",
df->df_idf->id_text);
}
FreeNode(nd);
}
]
| |
{ id = gen_anon_idf(); } /* Aha, third edition? */
] /* Changed rule in new modula-2 */ ':' qualident(D_TYPE|D_HTYPE|D_HIDDEN,
':' qualident(D_TYPE|D_HTYPE, &df, "type", (struct node **) 0) &df,
{ df1 = define(id, scope, D_FIELD); "type",
(struct node **) 0)
{
id = gen_anon_idf();
}
]
{
df1 = define(id, scope, D_FIELD);
df1->df_type = df->df_type; df1->df_type = df->df_type;
} }
OF variant(scope) OF variant(scope)
@ -362,7 +401,7 @@ PointerType(struct type **ptp;)
/* 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
*/ */
qualident(D_TYPE|D_HTYPE, &df, "type", (struct node **) 0) qualident(D_TYPE|D_HTYPE|D_HIDDEN, &df, "type", (struct node **) 0)
{ {
if (!df->df_type) { if (!df->df_type) {
error("type \"%s\" not declared", error("type \"%s\" not declared",
@ -428,7 +467,7 @@ FormalTypeList(struct paramlist **ppr; struct type **ptp;)
{ p->next = 0; } { p->next = 0; }
]? ]?
')' ')'
[ ':' qualident(D_TYPE|D_HTYPE, &df, "type", (struct node **) 0) [ ':' qualident(D_TYPE|D_HTYPE|D_HIDDEN, &df, "type", (struct node **) 0)
{ *ptp = df->df_type; } { *ptp = df->df_type; }
]? ]?
; ;

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

@ -43,8 +43,12 @@ struct dfproc {
}; };
struct import { struct import {
struct def *im_def; /* imported definition */ union {
#define imp_def df_value.df_import.im_def struct def *im_def; /* imported definition */
struct node *im_nodef; /* imported from undefined name */
} im_u;
#define imp_def df_value.df_import.im_u.im_def
#define imp_nodef df_value.df_import.im_u.im_nodef
}; };
struct def { /* list of definitions for a name */ struct def { /* list of definitions for a name */
@ -65,12 +69,12 @@ struct def { /* list of definitions for a name */
#define D_PROCHEAD 0x0100 /* a procedure heading in a definition module */ #define D_PROCHEAD 0x0100 /* a procedure heading in a definition module */
#define D_HIDDEN 0x0200 /* a hidden type */ #define D_HIDDEN 0x0200 /* a hidden type */
#define D_HTYPE 0x0400 /* definition of a hidden type seen */ #define D_HTYPE 0x0400 /* definition of a hidden type seen */
#define D_STDPROC 0x0800 /* a standard procedure */ #define D_FORWARD 0x0800 /* not yet defined */
#define D_STDFUNC 0x1000 /* a standard function */ #define D_UNDEF_IMPORT 0x1000 /* imported from an undefined name */
#define D_ERROR 0x2000 /* a compiler generated definition for an #define D_FORWMODULE 0x2000 /* module must be declared later */
#define D_ERROR 0x4000 /* a compiler generated definition for an
undefined variable undefined variable
*/ */
#define D_ISEXPORTED 0x4000 /* not yet defined */
char df_flags; char df_flags;
#define D_ADDRESS 0x01 /* set if address was taken */ #define D_ADDRESS 0x01 /* set if address was taken */
#define D_USED 0x02 /* set if used */ #define D_USED 0x02 /* set if used */

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

@ -7,7 +7,6 @@ static char *RcsId = "$Header$";
#include <em_label.h> #include <em_label.h>
#include <assert.h> #include <assert.h>
#include "main.h" #include "main.h"
#include "Lpars.h"
#include "def.h" #include "def.h"
#include "type.h" #include "type.h"
#include "idf.h" #include "idf.h"
@ -33,7 +32,8 @@ define(id, scope, kind)
*/ */
register struct def *df; register struct def *df;
DO_DEBUG(5, debug("Defining identifier \"%s\" in scope %d", id->id_text, scope->sc_scope)); DO_DEBUG(5, debug("Defining identifier \"%s\" in scope %d, kind = %d",
id->id_text, scope->sc_scope, kind));
df = lookup(id, scope->sc_scope); df = lookup(id, scope->sc_scope);
if ( /* Already in this scope */ if ( /* Already in this scope */
df df
@ -47,7 +47,10 @@ define(id, scope, kind)
switch(df->df_kind) { switch(df->df_kind) {
case D_PROCHEAD: case D_PROCHEAD:
if (kind == D_PROCEDURE) { if (kind == D_PROCEDURE) {
df->df_kind = D_PROCEDURE; /* Definition of which the heading was
already seen in a definition module
*/
df->df_kind = kind;
return df; return df;
} }
break; break;
@ -57,8 +60,14 @@ define(id, scope, kind)
return df; return df;
} }
break; break;
case D_FORWMODULE:
if (kind & (D_FORWMODULE|D_MODULE)) {
df->df_kind = kind;
return df;
}
break;
case D_ERROR: case D_ERROR:
case D_ISEXPORTED: case D_FORWARD:
df->df_kind = kind; df->df_kind = kind;
return df; return df;
} }
@ -72,6 +81,7 @@ error("identifier \"%s\" already declared", id->id_text);
df->df_scope = scope->sc_scope; df->df_scope = scope->sc_scope;
df->df_kind = kind; df->df_kind = kind;
df->next = id->id_def; df->next = id->id_def;
df->df_flags = 0;
id->id_def = df; id->id_def = df;
/* enter the definition in the list of definitions in this scope */ /* enter the definition in the list of definitions in this scope */
@ -101,6 +111,21 @@ lookup(id, scope)
assert(df != 0); assert(df != 0);
return df; return df;
} }
if (df->df_kind == D_UNDEF_IMPORT) {
df1 = df->imp_def;
assert(df1 != 0);
if (df1->df_kind == D_MODULE) {
df1 = lookup(id, df1->mod_scope);
if (df1) {
df->df_kind = D_IMPORT;
df->imp_def = df1;
}
return df1;
}
return df;
}
if (df1) { if (df1) {
df1->next = df->next; df1->next = df->next;
df->next = id->id_def; df->next = id->id_def;
@ -122,17 +147,31 @@ Export(ids, qualified)
all the "ids" visible in the enclosing scope by defining them all the "ids" visible in the enclosing scope by defining them
in this scope as "imported". in this scope as "imported".
*/ */
register struct def *df; register struct def *df, *df1;
while (ids) { while (ids) {
df = define(ids->nd_IDF, CurrentScope, D_ISEXPORTED); df = define(ids->nd_IDF, CurrentScope, D_FORWARD);
if (qualified) { if (qualified) {
df->df_flags |= D_QEXPORTED; df->df_flags |= D_QEXPORTED;
} }
else { else {
df->df_flags |= D_EXPORTED; df->df_flags |= D_EXPORTED;
df = define(ids->nd_IDF, enclosing(CurrentScope), df1 = lookup(ids->nd_IDF,
D_IMPORT); enclosing(CurrentScope)->sc_scope);
if (! df1 || !(df1->df_kind & (D_PROCHEAD|D_HIDDEN))) {
df1 = define(ids->nd_IDF,
enclosing(CurrentScope),
D_IMPORT);
}
else {
/* A hidden type or a procedure of which only
the head is seen. Apparently, they are
exported from a local module!
*/
df->df_kind = df1->df_kind;
df1->df_kind = D_IMPORT;
}
df1->imp_def = df;
} }
ids = ids->next; ids = ids->next;
} }
@ -168,9 +207,24 @@ Import(ids, idn, local)
if (!idn) imp_kind = FROM_ENCLOSING; if (!idn) imp_kind = FROM_ENCLOSING;
else { else {
imp_kind = FROM_MODULE; imp_kind = FROM_MODULE;
if (local) df = lookfor(idn, enclosing(CurrentScope), 1); if (local) {
else df = GetDefinitionModule(idn->nd_IDF); df = lookfor(idn, enclosing(CurrentScope), 0);
if (df->df_kind != D_MODULE) { if (df->df_kind == D_ERROR) {
/* 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.
???
*/
df->df_scope = scope;
df->df_kind = D_FORWMODULE;
df->mod_scope = -1;
kind = D_UNDEF_IMPORT;
}
}
else {
df = GetDefinitionModule(idn->nd_IDF);
}
if (!(df->df_kind & (D_MODULE|D_FORWMODULE))) {
/* enter all "ids" with type D_ERROR */ /* enter all "ids" with type D_ERROR */
kind = D_ERROR; kind = D_ERROR;
if (df->df_kind != D_ERROR) { if (df->df_kind != D_ERROR) {
@ -181,13 +235,14 @@ node_error(idn, "identifier \"%s\" does not represent a module", idn->nd_IDF->id
} }
while (ids) { while (ids) {
if (imp_kind == FROM_MODULE) { if (imp_kind == FROM_MODULE) {
if (!(df = lookup(ids->nd_IDF, scope))) { if (scope == -1) {
}
else if (!(df = lookup(ids->nd_IDF, scope))) {
node_error(ids, "identifier \"%s\" not declared in qualifying module", node_error(ids, "identifier \"%s\" not declared in qualifying module",
ids->nd_IDF->id_text); ids->nd_IDF->id_text);
df = ill_df; df = ill_df;
} }
else else if (!(df->df_flags&(D_EXPORTED|D_QEXPORTED))) {
if (!(df->df_flags&(D_EXPORTED|D_QEXPORTED))) {
node_error(ids,"identifier \"%s\" not exported from qualifying module", node_error(ids,"identifier \"%s\" not exported from qualifying module",
ids->nd_IDF->id_text); ids->nd_IDF->id_text);
} }

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

@ -29,7 +29,7 @@ Enter(name, kind, type, pnam)
if (!id) fatal("Out of core"); if (!id) fatal("Out of core");
df = define(id, CurrentScope, kind); df = define(id, CurrentScope, kind);
df->df_type = type; df->df_type = type;
if (kind == D_STDPROC || kind == D_STDFUNC) { if (type = std_type) {
df->df_value.df_stdname = pnam; df->df_value.df_stdname = pnam;
} }
return df; return df;
@ -54,7 +54,7 @@ EnterIdList(idlist, kind, flags, type, scope)
while (idlist) { while (idlist) {
df = define(idlist->nd_IDF, scope, kind); df = define(idlist->nd_IDF, scope, kind);
df->df_type = type; df->df_type = type;
df->df_flags = flags; df->df_flags |= flags;
if (kind == D_ENUM) { if (kind == D_ENUM) {
if (!first) first = df; if (!first) first = df;
df->enm_val = assval++; df->enm_val = assval++;

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

@ -48,8 +48,7 @@ qualident(int types; struct def **pdf; char *str; struct node **p;)
findname(nd); findname(nd);
assert(nd->nd_class == Def); assert(nd->nd_class == Def);
*pdf = df = nd->nd_def; *pdf = df = nd->nd_def;
if (df->df_kind != D_ERROR && if ( !((types|D_ERROR) & df->df_kind)) {
!(types & df->df_kind)) {
error("identifier \"%s\" is not a %s", error("identifier \"%s\" is not a %s",
df->df_idf->id_text, str); df->df_idf->id_text, str);
} }
@ -183,7 +182,11 @@ factor(struct node **p;)
number(p) number(p)
| |
STRING { *p = MkNode(Value, NULLNODE, NULLNODE, &dot); STRING { *p = MkNode(Value, NULLNODE, NULLNODE, &dot);
(*p)->nd_type = string_type; if (dot.TOK_SLE == 1) {
dot.TOK_INT = *(dot.TOK_STR);
(*p)->nd_type = char_type;
}
else (*p)->nd_type = string_type;
} }
| |
'(' expression(p) ')' '(' expression(p) ')'

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

@ -68,6 +68,9 @@ struct type {
#define T_PROCEDURE 0x1000 #define T_PROCEDURE 0x1000
#define T_ARRAY 0x2000 #define T_ARRAY 0x2000
#define T_STRING 0x4000 #define T_STRING 0x4000
#define T_INTORCARD (T_INTEGER|T_CARDINAL)
#define T_DISCRETE (T_ENUMERATION|T_INTORCARD|T_CHAR)
#define T_NUMERIC (T_INTORCARD|T_REAL)
int tp_align; /* alignment requirement of this type */ int tp_align; /* alignment requirement of this type */
arith tp_size; /* size of this type */ arith tp_size; /* size of this type */
union { union {

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

@ -7,7 +7,6 @@ static char *RcsId = "$Header$";
#include <em_arith.h> #include <em_arith.h>
#include <em_label.h> #include <em_label.h>
#include "def_sizes.h" #include "def_sizes.h"
#include "Lpars.h"
#include "def.h" #include "def.h"
#include "type.h" #include "type.h"
#include "idf.h" #include "idf.h"
@ -141,7 +140,7 @@ init_types()
real_type = standard_type(T_REAL, real_align, real_size); real_type = standard_type(T_REAL, real_align, real_size);
longreal_type = standard_type(T_REAL, lreal_align, lreal_size); longreal_type = standard_type(T_REAL, lreal_align, lreal_size);
word_type = standard_type(T_WORD, wrd_align, wrd_size); word_type = standard_type(T_WORD, wrd_align, wrd_size);
intorcard_type = standard_type(T_INTEGER, int_align, int_size); intorcard_type = standard_type(T_INTORCARD, int_align, int_size);
string_type = standard_type(T_STRING, 1, (arith) -1); string_type = standard_type(T_STRING, 1, (arith) -1);
address_type = construct_type(T_POINTER, word_type); address_type = construct_type(T_POINTER, word_type);
tp = construct_type(T_SUBRANGE, int_type); tp = construct_type(T_SUBRANGE, int_type);

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

@ -6,16 +6,17 @@ static char *RcsId = "$Header$";
#include <em_label.h> #include <em_label.h>
#include "type.h" #include "type.h"
#include "def.h" #include "def.h"
#include "Lpars.h"
int int
TstTypeEquiv(tp1, tp2) TstTypeEquiv(tp1, tp2)
register struct type *tp1, *tp2; register struct type *tp1, *tp2;
{ {
/* test if two types are equivalent. The only complication comes /* test if two types are equivalent. A complication comes
from the fact that for some procedures two declarations may from the fact that for some procedures two declarations may
be given: one in the specification module and one in the be given: one in the specification module and one in the
definition module. definition module.
A related problem is that two dynamic arrays with the
same base type are also equivalent.
*/ */
return tp1 == tp2 return tp1 == tp2
@ -23,6 +24,18 @@ TstTypeEquiv(tp1, tp2)
tp1 == error_type tp1 == error_type
|| ||
tp2 == error_type tp2 == error_type
||
(
tp1->tp_fund == T_ARRAY
&&
tp1->next == 0
&&
tp2->tp_fund == T_ARRAY
&&
tp2->next == 0
&&
TstTypeEquiv(tp1->arr_elem, tp2->arr_elem)
)
|| ||
( (
tp1 && tp1->tp_fund == T_PROCEDURE tp1 && tp1->tp_fund == T_PROCEDURE