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-05-28 18:36:51 +00:00
parent 441ba991fa
commit 6382054ae5
23 changed files with 671 additions and 196 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -182,10 +182,6 @@ again:
if (nch == '=') {
return tk->tk_symb = LESSEQUAL;
}
else
if (nch == '>') {
return tk->tk_symb = '#';
}
PushBack(nch);
return tk->tk_symb = ch;

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

@ -4,6 +4,12 @@
static char *RcsId = "$Header$";
#endif
/* Defines the LLmessage routine. LLgen-generated parsers require the
existence of a routine of that name.
The routine must do syntax-error reporting and must be able to
insert tokens in the token stream.
*/
#include <alloc.h>
#include <em_arith.h>
#include <em_label.h>
@ -12,15 +18,18 @@ static char *RcsId = "$Header$";
#include "LLlex.h"
#include "Lpars.h"
extern char *symbol2str();
extern struct idf *gen_anon_idf();
int err_occurred = 0;
extern char *symbol2str();
extern struct idf *gen_anon_idf();
int err_occurred = 0;
LLmessage(tk)
int tk;
{
++err_occurred;
if (tk) {
/* if (tk != 0), it represents the token to be inserted.
otherwize, the current token is deleted
*/
error("%s missing", symbol2str(tk));
insert_token(tk);
}

7
lang/m2/comp/Makefile
View file

@ -11,7 +11,7 @@ LSRC = tokenfile.g program.g declar.g expression.g statement.g
CC = cc
GEN = LLgen
GENOPTIONS =
PROFILE =
PROFILE =
CFLAGS = $(PROFILE) $(INCLUDES)
LFLAGS = $(PROFILE)
LOBJ = tokenfile.o program.o declar.o expression.o statement.o
@ -91,7 +91,7 @@ tokenname.o: Lpars.h idf.h tokenname.h
idf.o: idf.h
input.o: f_info.h input.h inputtype.h
type.o: LLlex.h const.h debug.h def.h idf.h maxset.h node.h target_sizes.h type.h
def.o: LLlex.h debug.h def.h idf.h main.h node.h scope.h type.h
def.o: LLlex.h Lpars.h debug.h def.h idf.h main.h node.h scope.h type.h
scope.o: LLlex.h debug.h def.h idf.h node.h scope.h type.h
misc.o: LLlex.h f_info.h idf.h misc.h node.h
enter.o: LLlex.h debug.h def.h idf.h main.h node.h scope.h type.h
@ -101,10 +101,11 @@ node.o: LLlex.h debug.h def.h node.h type.h
cstoper.o: LLlex.h Lpars.h debug.h idf.h node.h standards.h target_sizes.h type.h
chk_expr.o: LLlex.h Lpars.h const.h debug.h def.h idf.h node.h scope.h standards.h type.h
options.o: idfsize.h main.h ndir.h type.h
walk.o: LLlex.h Lpars.h debug.h def.h desig.h main.h node.h scope.h type.h
walk.o: LLlex.h Lpars.h debug.h def.h desig.h f_info.h idf.h main.h node.h scope.h type.h
casestat.o: LLlex.h Lpars.h debug.h density.h desig.h node.h type.h
desig.o: LLlex.h debug.h def.h desig.h node.h scope.h type.h
code.o: LLlex.h Lpars.h debug.h def.h desig.h node.h scope.h type.h
tmpvar.o: debug.h def.h scope.h type.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
declar.o: LLlex.h Lpars.h debug.h def.h idf.h main.h misc.h node.h scope.h type.h

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

@ -63,15 +63,12 @@ CaseCode(nd, exitlabel)
register arith val;
label tablabel;
assert(nd->nd_class == Stat && nd->nd_symb == CASE);
assert(pnode->nd_class == Stat && pnode->nd_symb == CASE);
WalkExpr(nd->nd_left, NO_LABEL, NO_LABEL);
sh->sh_type = nd->nd_left->nd_type;
clear((char *) sh, sizeof(*sh));
WalkExpr(pnode->nd_left, NO_LABEL, NO_LABEL);
sh->sh_type = pnode->nd_left->nd_type;
sh->sh_break = text_label();
sh->sh_default = 0;
sh->sh_nrofentries = 0;
sh->sh_lowerbd = sh->sh_upperbd = (arith)0; /* immaterial ??? */
sh->sh_entries = (struct case_entry *) 0; /* case-entry list */
/* Now, create case label list
*/
@ -189,6 +186,7 @@ AddCases(sh, node, lbl)
if (node->nd_symb == UPTO) {
assert(node->nd_left->nd_class == Value);
assert(node->nd_right->nd_class == Value);
v2 = node->nd_right->nd_INT;
node->nd_type = node->nd_left->nd_type;
for (v1 = node->nd_left->nd_INT; v1 <= v2; v1++) {
@ -233,9 +231,12 @@ AddOneCase(sh, node, lbl)
/* second etc. case entry */
/* find the proper place to put ce into the list */
if (ce->ce_value < sh->sh_lowerbd) sh->sh_lowerbd = ce->ce_value;
else
if (ce->ce_value > sh->sh_upperbd) sh->sh_upperbd = ce->ce_value;
if (ce->ce_value < sh->sh_lowerbd) {
sh->sh_lowerbd = ce->ce_value;
}
else if (ce->ce_value > sh->sh_upperbd) {
sh->sh_upperbd = ce->ce_value;
}
while (c1 && c1->ce_value < ce->ce_value) {
c2 = c1;
c1 = c1->next;

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

@ -38,7 +38,7 @@ chk_expr(expp)
switch(expp->nd_class) {
case Oper:
if (expp->nd_symb == '[') {
return chk_designator(expp, DESIGNATOR|VARIABLE);
return chk_designator(expp, DESIGNATOR|VARIABLE, D_NOREG|D_USED);
}
return chk_expr(expp->nd_left) &&
@ -47,7 +47,7 @@ chk_expr(expp)
case Uoper:
if (expp->nd_symb == '^') {
return chk_designator(expp, DESIGNATOR|VARIABLE);
return chk_designator(expp, DESIGNATOR|VARIABLE, D_USED);
}
return chk_expr(expp->nd_right) &&
@ -69,13 +69,13 @@ chk_expr(expp)
return chk_set(expp);
case Name:
return chk_designator(expp, VALUE);
return chk_designator(expp, VALUE, D_USED);
case Call:
return chk_call(expp);
case Link:
return chk_designator(expp, DESIGNATOR|VALUE);
return chk_designator(expp, DESIGNATOR|VALUE, D_USED|D_NOREG);
default:
assert(0);
@ -94,6 +94,7 @@ chk_set(expp)
struct def *df;
register struct node *nd;
arith *set;
unsigned size;
assert(expp->nd_symb == SET);
@ -102,7 +103,7 @@ chk_set(expp)
if (nd = expp->nd_left) {
/* A type was given. Check it out
*/
if (! chk_designator(nd, 0)) return 0;
if (! chk_designator(nd, 0, D_USED)) return 0;
assert(nd->nd_class == Def);
df = nd->nd_def;
@ -117,16 +118,26 @@ chk_set(expp)
expp->nd_left = 0;
}
else tp = bitset_type;
expp->nd_type = tp;
nd = expp->nd_right;
/* Now check the elements given, and try to compute a constant set.
First allocate room for the set
First allocate room for the set, but only if it is'nt empty.
*/
set = (arith *)
Malloc((unsigned) (tp->tp_size * sizeof(arith) / word_size));
if (! nd) {
/* The resulting set IS empty, so we just return
*/
expp->nd_class = Set;
expp->nd_set = 0;
return 1;
}
size = tp->tp_size * (sizeof(arith) / word_size);
set = (arith *) Malloc(size);
clear((char *) set, size);
/* Now check the elements, one by one
*/
nd = expp->nd_right;
while (nd) {
assert(nd->nd_class == Link && nd->nd_symb == ',');
@ -134,8 +145,6 @@ chk_set(expp)
nd = nd->nd_right;
}
expp->nd_type = tp;
if (set) {
/* Yes, it was a constant set, and we managed to compute it!
Notice that at the moment there is no such thing as
@ -255,7 +264,7 @@ getarg(argp, bases, designator)
}
argp = argp->nd_right;
if ((!designator && !chk_expr(argp->nd_left)) ||
(designator && !chk_designator(argp->nd_left, DESIGNATOR))) {
(designator && !chk_designator(argp->nd_left, DESIGNATOR, D_REFERRED))) {
return 0;
}
tp = argp->nd_left->nd_type;
@ -276,7 +285,7 @@ getname(argp, kinds)
return 0;
}
argp = argp->nd_right;
if (! chk_designator(argp->nd_left, 0)) return 0;
if (! chk_designator(argp->nd_left, 0, D_REFERRED)) return 0;
assert(argp->nd_left->nd_class == Def);
@ -303,10 +312,9 @@ chk_call(expp)
*/
expp->nd_type = error_type;
left = expp->nd_left;
if (! chk_designator(left, 0)) return 0;
if (! chk_designator(left, 0, D_USED)) return 0;
if (left->nd_class == Def &&
(left->nd_def->df_kind & (D_HTYPE|D_TYPE|D_HIDDEN))) {
if (left->nd_class == Def && is_type(left->nd_def)) {
/* It was a type cast. This is of course not portable.
*/
arg = expp->nd_right;
@ -359,10 +367,21 @@ chk_proccall(expp)
{
/* Check a procedure call
*/
register struct node *left = expp->nd_left;
register struct node *left;
register struct node *arg;
register struct paramlist *param;
left = 0;
arg = expp->nd_right;
/* First, reverse the order in the argument list */
while (arg) {
expp->nd_right = arg;
arg = arg->nd_right;
expp->nd_right->nd_right = left;
left = expp->nd_right;
}
left = expp->nd_left;
arg = expp;
arg->nd_type = left->nd_type->next;
param = left->nd_type->prc_params;
@ -376,6 +395,9 @@ chk_proccall(expp)
node_error(arg->nd_left, "type incompatibility in parameter");
return 0;
}
if (param->par_var && arg->nd_left->nd_class == Def) {
arg->nd_left->nd_def->df_flags |= D_NOREG;
}
param = param->next;
}
@ -422,7 +444,7 @@ FlagCheck(expp, df, flag)
}
int
chk_designator(expp, flag)
chk_designator(expp, flag, dflags)
register struct node *expp;
{
/* Find the name indicated by "expp", starting from the current
@ -435,6 +457,8 @@ chk_designator(expp, flag)
and '^' are allowed for this designator.
Also contained may be the flag HASSELECTORS, indicating that
the result must have selectors.
"dflags" contains some flags that must be set at the definition
found.
*/
register struct def *df;
register struct type *tp;
@ -454,7 +478,8 @@ chk_designator(expp, flag)
assert(expp->nd_right->nd_class == Name);
if (! chk_designator(expp->nd_left,
(flag|HASSELECTORS))) return 0;
flag|HASSELECTORS,
dflags|D_NOREG)) return 0;
tp = expp->nd_left->nd_type;
@ -512,6 +537,8 @@ df->df_idf->id_text);
}
}
df->df_flags |= dflags;
return 1;
}
@ -526,7 +553,7 @@ df->df_idf->id_text);
assert(expp->nd_symb == '[');
if (
!chk_designator(expp->nd_left, DESIGNATOR|VARIABLE)
!chk_designator(expp->nd_left, DESIGNATOR|VARIABLE, dflags|D_NOREG)
||
!chk_expr(expp->nd_right)
||
@ -558,7 +585,7 @@ df->df_idf->id_text);
if (expp->nd_class == Uoper) {
assert(expp->nd_symb == '^');
if (! chk_designator(expp->nd_right, DESIGNATOR|VARIABLE)) {
if (! chk_designator(expp->nd_right, DESIGNATOR|VARIABLE, dflags)) {
return 0;
}
@ -703,7 +730,6 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R
case '=':
case '#':
case UNEQUAL:
case GREATEREQUAL:
case LESSEQUAL:
case '<':
@ -732,7 +758,6 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R
case T_POINTER:
if (chk_address(tpl, tpr) ||
expp->nd_symb == '=' ||
expp->nd_symb == UNEQUAL ||
expp->nd_symb == '#') return 1;
break;
@ -790,6 +815,7 @@ chk_uoper(expp)
case '+':
if (tpr->tp_fund & T_NUMERIC) {
expp->nd_token = right->nd_token;
expp->nd_class = right->nd_class;
FreeNode(right);
expp->nd_right = 0;
return 1;
@ -809,10 +835,14 @@ chk_uoper(expp)
else if (tpr->tp_fund == T_REAL) {
if (right->nd_class == Value) {
expp->nd_token = right->nd_token;
expp->nd_class = Value;
if (*(expp->nd_REL) == '-') {
expp->nd_REL++;
}
else expp->nd_REL--;
else {
expp->nd_REL--;
*(expp->nd_REL) = '-';
}
FreeNode(right);
expp->nd_right = 0;
}
@ -853,7 +883,7 @@ getvariable(arg)
left = arg->nd_left;
if (! chk_designator(left, DESIGNATOR)) return 0;
if (! chk_designator(left, DESIGNATOR, D_REFERRED)) return 0;
if (left->nd_class == Oper || left->nd_class == Uoper) {
return arg;
}
@ -941,7 +971,7 @@ left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname));
case S_TSIZE: /* ??? */
case S_SIZE:
expp->nd_type = intorcard_type;
arg = getname(arg, D_FIELD|D_VARIABLE|D_TYPE|D_HIDDEN|D_HTYPE);
arg = getname(arg, D_FIELD|D_VARIABLE|D_ISTYPE);
if (!arg) return 0;
cstcall(expp, S_SIZE);
break;
@ -955,7 +985,7 @@ left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname));
{
struct type *tp;
if (!(arg = getname(arg, D_HIDDEN|D_HTYPE|D_TYPE))) return 0;
if (!(arg = getname(arg, D_ISTYPE))) return 0;
tp = arg->nd_left->nd_def->df_type;
if (tp->tp_fund == T_SUBRANGE) tp = tp->next;
if (!(tp->tp_fund & T_DISCRETE)) {

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

@ -52,14 +52,14 @@ CodeString(nd)
struct node *nd;
{
label lab;
if (nd->nd_type == charc_type) {
C_loc(nd->nd_INT);
return;
}
C_df_dlb(lab = data_label());
C_rom_scon(nd->nd_STR, nd->nd_SLE);
C_lae_dlb(lab);
C_lae_dlb(lab, (arith) 0);
}
CodeReal(nd)
@ -69,7 +69,7 @@ CodeReal(nd)
C_df_dlb(lab = data_label());
C_rom_fcon(nd->nd_REL, nd->nd_type->tp_size);
C_lae_dlb(lab);
C_lae_dlb(lab, (arith) 0);
C_loi(nd->nd_type->tp_size);
}
@ -139,12 +139,16 @@ CodeExpr(nd, ds, true_label, false_label)
int i;
st = nd->nd_set;
for (i = nd->nd_type->tp_size / word_size, st = nd->nd_set + i;
ds->dsg_kind = DSG_LOADED;
if (!st) {
C_zer(nd->nd_type->tp_size);
break;
}
for (i = nd->nd_type->tp_size / word_size, st += i;
i > 0;
i--) {
C_loc(*--st);
}
ds->dsg_kind = DSG_LOADED;
}
break;
@ -166,9 +170,97 @@ CodeExpr(nd, ds, true_label, false_label)
}
CodeCoercion(t1, t2)
struct type *t1, *t2;
register struct type *t1, *t2;
{
/* ??? */
int fund1, fund2;
if (t1 == t2) return;
if (t1->tp_fund == T_SUBRANGE) t1 = t1->next;
if (t2->tp_fund == T_SUBRANGE) t2 = t2->next;
if ((fund1 = t1->tp_fund) == T_WORD) fund1 = T_INTEGER;
if ((fund2 = t2->tp_fund) == T_WORD) fund2 = T_INTEGER;
switch(fund1) {
case T_INTEGER:
switch(fund2) {
case T_INTEGER:
if (t2->tp_size != t1->tp_size) {
C_loc(t1->tp_size);
C_loc(t2->tp_size);
C_cii();
}
break;
case T_ENUMERATION:
case T_CHAR:
case T_CARDINAL:
if (t1->tp_size != word_size) {
C_loc(t1->tp_size);
C_loc(word_size);
C_ciu();
}
break;
case T_REAL:
C_loc(t1->tp_size);
C_loc(t2->tp_size);
C_cif();
break;
default:
crash("Funny integer conversion");
}
break;
case T_CHAR:
case T_ENUMERATION:
case T_CARDINAL:
switch(fund2) {
case T_ENUMERATION:
case T_CHAR:
case T_CARDINAL:
case T_POINTER:
if (t2->tp_size > word_size) {
C_loc(word_size);
C_loc(t2->tp_size);
C_cuu();
}
break;
case T_INTEGER:
C_loc(t1->tp_size);
C_loc(t2->tp_size);
C_cui();
break;
case T_REAL:
C_loc(t1->tp_size);
C_loc(t2->tp_size);
C_cuf();
break;
default:
crash("Funny cardinal conversion");
}
break;
case T_REAL:
switch(fund2) {
case T_REAL:
if (t2->tp_size != t1->tp_size) {
C_loc(t1->tp_size);
C_loc(t2->tp_size);
C_cff();
}
break;
case T_INTEGER:
C_loc(t1->tp_size);
C_loc(t2->tp_size);
C_cfi();
break;
case T_CARDINAL:
C_loc(t1->tp_size);
C_loc(t2->tp_size);
C_cfu();
break;
default:
crash("Funny REAL conversion");
}
break;
}
}
CodeCall(nd)
@ -190,13 +282,12 @@ CodeCall(nd)
}
tp = left->nd_type;
if (left->nd_class == Def &&
(left->nd_def->df_kind & (D_TYPE|D_HTYPE|D_HIDDEN))) {
if (left->nd_class == Def && is_type(left->nd_def)) {
/* it was just a cast. Simply ignore it
*/
Des = InitDesig;
CodeExpr(nd->nd_right->nd_left, &Des, NO_LABEL, NO_LABEL);
CodeValue(&Des);
CodeValue(&Des, tp->tp_size);
*nd = *(nd->nd_right->nd_left);
nd->nd_type = left->nd_def->df_type;
return;
@ -216,6 +307,7 @@ CodeCall(nd)
else {
CodeExpr(arg->nd_left, &Des, NO_LABEL, NO_LABEL);
CodeValue(&Des, arg->nd_left->nd_type->tp_size);
CheckAssign(arg->nd_left->nd_type, param->par_type);
pushed += align(arg->nd_left->nd_type->tp_size, word_align);
}
/* ??? Conformant arrays */
@ -249,16 +341,55 @@ CodeStd(nd)
/* ??? */
}
CodeAssign(nd, dst, dss)
CodeAssign(nd, dss, dst)
struct node *nd;
struct desig *dst, *dss;
{
/* Generate code for an assignment. Testing of type
compatibility and the like is already done.
*/
CodeCoercion(nd->nd_right->nd_type, nd->nd_left->nd_type);
/* ??? */
if (dss->dsg_kind == DSG_LOADED) {
CodeStore(dst, nd->nd_left->nd_type->tp_size);
}
else {
CodeAddress(dst);
C_blm(nd->nd_left->nd_type->tp_size);
}
}
CheckAssign(tpl, tpr)
register struct type *tpl, *tpr;
{
/* Generate a range check if neccessary
*/
arith llo, lhi, rlo, rhi;
label l = 0;
extern label getrck();
if (bounded(tpl)) {
/* in this case we might need a range check */
if (!bounded(tpr)) {
/* yes, we need one */
l = getrck(tpl);
}
else {
/* both types are restricted. check the bounds
to see wether we need a range check
*/
getbounds(tpl, &llo, &lhi);
getbounds(tpr, &rlo, &rhi);
if (llo > rlo || lhi < rhi) {
l = getrck(tpl);
}
}
if (l) {
C_lae_dlb(l, (arith) 0);
C_rck(word_size);
}
}
}
Operands(leftop, rightop)
@ -415,29 +546,44 @@ CodeOper(expr, true_label, false_label)
case '>':
case GREATEREQUAL:
case '=':
case UNEQUAL:
case '#':
Operands(leftop, rightop);
CodeCoercion(rightop->nd_type, leftop->nd_type);
tp = leftop->nd_type; /* Not the result type! */
if (tp->tp_fund == T_SUBRANGE) tp = tp->next;
switch (tp->tp_fund) {
case T_INTEGER:
C_cmi(leftop->nd_type->tp_size);
C_cmi(tp->tp_size);
break;
case T_POINTER:
C_cmp();
break;
case T_CARDINAL:
C_cmu(leftop->nd_type->tp_size);
C_cmu(tp->tp_size);
break;
case T_ENUMERATION:
case T_CHAR:
C_cmu(word_size);
break;
case T_REAL:
C_cmf(leftop->nd_type->tp_size);
C_cmf(tp->tp_size);
break;
case T_SET:
C_cms(leftop->nd_type->tp_size);
if (oper == GREATEREQUAL) {
/* A >= B is the same as A equals A + B
*/
C_dup(2*tp->tp_size);
C_asp(tp->tp_size);
C_zer(tp->tp_size);
}
else if (oper == LESSEQUAL) {
/* A <= B is the same as A - B = {}
*/
C_com(tp->tp_size);
C_and(tp->tp_size);
C_ior(tp->tp_size);
}
C_cms(tp->tp_size);
break;
default:
crash("bad type COMPARE");
@ -451,9 +597,13 @@ CodeOper(expr, true_label, false_label)
}
break;
case IN:
Operands(leftop, rightop);
CodeCoercion(rightop->nd_type, word_type);
C_inn(leftop->nd_type->tp_size);
/* In this case, evaluate right hand side first! The
INN instruction expects the bit number on top of the
stack
*/
Operands(rightop, leftop);
CodeCoercion(leftop->nd_type, word_type);
C_inn(rightop->nd_type->tp_size);
break;
case AND:
case '&':
@ -544,7 +694,6 @@ compare(relop, lbl)
case '=':
C_zeq(lbl);
break;
case UNEQUAL:
case '#':
C_zne(lbl);
break;
@ -573,7 +722,6 @@ truthvalue(relop)
case '=':
C_teq();
break;
case UNEQUAL:
case '#':
C_tne();
break;
@ -643,7 +791,7 @@ CodeEl(nd, tp)
Des = InitDesig;
CodeExpr(nd, &Des, NO_LABEL, NO_LABEL);
CodeValue(nd, word_size);
CodeValue(&Des, word_size);
C_set(tp->tp_size);
}
}

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

@ -45,7 +45,7 @@ cstunary(expp)
o1 = !o1;
break;
default:
assert(0);
crash("(cstunary)");
}
expp->nd_class = Value;
expp->nd_token = expp->nd_right->nd_token;
@ -159,7 +159,7 @@ cstbin(expp)
);
}
else
o1 = o1 < o2;
o1 = (o1 < o2);
break;
case '>':
@ -170,7 +170,7 @@ cstbin(expp)
);
}
else
o1 = o1 > o2;
o1 = (o1 > o2);
break;
case LESSEQUAL:
if (uns) {
@ -180,7 +180,7 @@ cstbin(expp)
);
}
else
o1 = o1 <= o2;
o1 = (o1 <= o2);
break;
case GREATEREQUAL:
if (uns) {
@ -190,27 +190,27 @@ cstbin(expp)
);
}
else
o1 = o1 >= o2;
o1 = (o1 >= o2);
break;
case '=':
o1 = o1 == o2;
o1 = (o1 == o2);
break;
case '#':
case UNEQUAL:
o1 = o1 != o2;
o1 = (o1 != o2);
break;
case AND:
case '&':
o1 = o1 && o2;
o1 = (o1 && o2);
break;
case OR:
o1 = o1 || o2;
o1 = (o1 || o2);
break;
default:
assert(0);
crash("(cstbin)");
}
expp->nd_class = Value;
expp->nd_token = expp->nd_right->nd_token;
if (expp->nd_type == bool_type) expp->nd_symb = INTEGER;
expp->nd_INT = o1;
CutSize(expp);
FreeNode(expp->nd_left);
@ -222,6 +222,7 @@ cstset(expp)
register struct node *expp;
{
register arith *set1 = 0, *set2;
arith *resultset = 0;
register int setsize, j;
assert(expp->nd_right->nd_class == Set);
@ -233,32 +234,59 @@ cstset(expp)
arith i;
assert(expp->nd_left->nd_class == Value);
i = expp->nd_left->nd_INT;
expp->nd_INT = (i >= 0 &&
expp->nd_INT = (i >= 0 && set2 != 0 &&
i < setsize * wrd_bits &&
(set2[i / wrd_bits] & (1 << (i % wrd_bits))));
free((char *) set2);
if (set2) free((char *) set2);
}
else {
set1 = expp->nd_left->nd_set;
resultset = set1;
expp->nd_left->nd_set = 0;
switch(expp->nd_symb) {
case '+':
for (j = 0; j < setsize; j++) {
if (!set1) {
resultset = set2;
expp->nd_right->nd_set = 0;
break;
}
if (set2) for (j = 0; j < setsize; j++) {
*set1++ |= *set2++;
}
break;
case '-':
if (!set1 || !set2) {
/* The set from which something is substracted
is already empty, or the set that is
substracted is empty
*/
break;
}
for (j = 0; j < setsize; j++) {
*set1++ &= ~*set2++;
}
break;
case '*':
if (!set1) break;
if (!set2) {
resultset = set2;
expp->nd_right->nd_set = 0;
break;
}
for (j = 0; j < setsize; j++) {
*set1++ &= *set2++;
}
break;
case '/':
for (j = 0; j < setsize; j++) {
if (!set1) {
resultset = set2;
expp->nd_right->nd_set = 0;
break;
}
if (set2) for (j = 0; j < setsize; j++) {
*set1++ ^= *set2++;
}
break;
@ -266,42 +294,62 @@ cstset(expp)
case LESSEQUAL:
case '=':
case '#':
case UNEQUAL:
/* Clumsy, but who cares? Nobody writes these things! */
expp->nd_left->nd_set = set1;
for (j = 0; j < setsize; j++) {
switch(expp->nd_symb) {
case GREATEREQUAL:
if (!set2) {j = setsize; break; }
if (!set1) break;
if ((*set1 | *set2++) != *set1) break;
set1++;
continue;
case LESSEQUAL:
if (!set1) {j = setsize; break; }
if (!set2) break;
if ((*set2 | *set1++) != *set2) break;
set2++;
continue;
case '=':
case '#':
case UNEQUAL:
if (!set1 && !set2) {
j = setsize; break;
}
if (!set1 || !set2) break;
if (*set1++ != *set2++) break;
continue;
}
expp->nd_INT = expp->nd_symb != '=';
if (j < setsize) {
expp->nd_INT = expp->nd_symb == '#';
}
else {
expp->nd_INT = expp->nd_symb != '#';
}
break;
}
if (j == setsize) expp->nd_INT = expp->nd_symb == '=';
expp->nd_class = Value;
expp->nd_symb = INTEGER;
free((char *) expp->nd_left->nd_set);
free((char *) expp->nd_right->nd_set);
if (expp->nd_left->nd_set) {
free((char *) expp->nd_left->nd_set);
}
if (expp->nd_right->nd_set) {
free((char *) expp->nd_right->nd_set);
}
FreeNode(expp->nd_left);
FreeNode(expp->nd_right);
expp->nd_left = expp->nd_right = 0;
return;
default:
assert(0);
crash("(cstset)");
}
if (expp->nd_right->nd_set) {
free((char *) expp->nd_right->nd_set);
}
if (expp->nd_left->nd_set) {
free((char *) expp->nd_left->nd_set);
}
free((char *) expp->nd_right->nd_set);
expp->nd_class = Set;
expp->nd_set = expp->nd_left->nd_set;
expp->nd_set = resultset;
}
FreeNode(expp->nd_left);
FreeNode(expp->nd_right);
@ -405,7 +453,7 @@ cstcall(expp, call)
else CutSize(expp);
break;
default:
assert(0);
crash("(cstcall)");
}
FreeNode(expr);
FreeNode(expp->nd_left);

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

@ -128,8 +128,7 @@ FormalParameters(int doparams;
]?
')'
{ *tp = 0; }
[ ':' qualident(D_TYPE|D_HTYPE|D_HIDDEN, &df, "type",
(struct node **) 0)
[ ':' qualident(D_ISTYPE, &df, "type", (struct node **) 0)
{ *tp = df->df_type;
}
]?
@ -169,7 +168,7 @@ FormalType(struct type **tp;)
} :
[ ARRAY OF { ARRAYflag = 1; }
]?
qualident(D_TYPE|D_HTYPE|D_HIDDEN, &df, "type", (struct node **) 0)
qualident(D_ISTYPE, &df, "type", (struct node **) 0)
{ if (ARRAYflag) {
*tp = construct_type(T_ARRAY, NULLTYPE);
(*tp)->arr_elem = df->df_type;
@ -186,14 +185,19 @@ TypeDeclaration
struct def *df;
struct type *tp;
}:
IDENT { df = define(dot.TOK_IDF, CurrentScope, D_TYPE); }
IDENT { df = lookup(dot.TOK_IDF, CurrentScope);
if (!df) df = define( dot.TOK_IDF,
CurrentScope,
D_TYPE);
}
'=' type(&tp)
{ if (df->df_type) free_type(df->df_type);
{ if (df->df_type) free_type(df->df_type); /* ??? */
df->df_type = tp;
if (df->df_kind == D_HTYPE &&
if (df->df_kind == D_HIDDEN &&
tp->tp_fund != T_POINTER) {
error("opaque type \"%s\" is not a pointer type", df->df_idf->id_text);
}
df->df_kind = D_TYPE;
}
;
@ -215,7 +219,7 @@ SimpleType(struct type **ptp;)
{
struct def *df;
} :
qualident(D_TYPE|D_HTYPE|D_HIDDEN, &df, "type", (struct node **) 0)
qualident(D_ISTYPE, &df, "type", (struct node **) 0)
[
/* nothing */
{ *ptp = df->df_type; }
@ -237,22 +241,16 @@ SimpleType(struct type **ptp;)
enumeration(struct type **ptp;)
{
struct node *EnumList;
register struct type *tp;
} :
'(' IdentList(&EnumList) ')'
{
*ptp = standard_type(T_ENUMERATION, 1, (arith) 1);
EnterIdList(EnumList, D_ENUM, 0, *ptp,
*ptp = tp = standard_type(T_ENUMERATION, 1, (arith) 1);
EnterIdList(EnumList, D_ENUM, 0, tp,
CurrentScope, (arith *) 0);
FreeNode(EnumList);
if ((*ptp)->enm_ncst > 256) {
if (word_size == 1) {
error("Too many enumeration literals");
}
else {
/* ??? This is crummy */
(*ptp)->tp_size = word_size;
(*ptp)->tp_align = word_align;
}
if (tp->enm_ncst > 256) {
error("Too many enumeration literals");
}
}
;
@ -284,7 +282,8 @@ SubrangeType(struct type **ptp;)
'[' ConstExpression(&nd1)
UPTO ConstExpression(&nd2)
']'
{ *ptp = subr_type(nd1, nd2); }
{ *ptp = subr_type(nd1, nd2);
}
;
ArrayType(struct type **ptp;)
@ -298,8 +297,8 @@ ArrayType(struct type **ptp;)
}
[
',' SimpleType(&tp)
{ tp2 = tp2->arr_elem =
construct_type(T_ARRAY, tp);
{ tp2->arr_elem = construct_type(T_ARRAY, tp);
tp2 = tp2->arr_elem;
}
]* OF type(&tp)
{ tp2->arr_elem = tp;
@ -365,8 +364,7 @@ FieldList(struct scope *scope; arith *cnt; int *palign;)
}
else id = nd->nd_IDF;
}
':' qualident(D_TYPE|D_HTYPE|D_HIDDEN,
&df, "type", (struct node **) 0)
':' qualident(D_ISTYPE, &df, "type", (struct node **) 0)
|
/* Old fashioned! the first qualident now represents
the type
@ -374,10 +372,10 @@ FieldList(struct scope *scope; arith *cnt; int *palign;)
{ warning("Old fashioned Modula-2 syntax!");
id = gen_anon_idf();
df = ill_df;
if (chk_designator(nd, 0) &&
if (chk_designator(nd, 0, D_REFERRED) &&
(nd->nd_class != Def ||
!(nd->nd_def->df_kind &
(D_ERROR|D_TYPE|D_HTYPE|D_HIDDEN)))) {
(D_ERROR|D_ISTYPE)))) {
node_error(nd, "type expected");
}
else df = nd->nd_def;
@ -386,7 +384,7 @@ FieldList(struct scope *scope; arith *cnt; int *palign;)
]
|
/* Aha, third edition? */
':' qualident(D_TYPE|D_HTYPE|D_HIDDEN, &df, "type", (struct node **) 0)
':' qualident(D_ISTYPE, &df, "type", (struct node **) 0)
{ id = gen_anon_idf(); }
]
{ tp = df->df_type;
@ -489,7 +487,7 @@ PointerType(struct type **ptp;)
/* Either a Module or a Type, but in both cases defined
in this scope, so this is the correct identification
*/
qualident(D_TYPE|D_HTYPE|D_HIDDEN, &df, "type", (struct node **) 0)
qualident(D_ISTYPE, &df, "type", (struct node **) 0)
{
if (!df->df_type) {
error("type \"%s\" not declared",
@ -555,7 +553,7 @@ FormalTypeList(struct paramlist **ppr; struct type **ptp;)
{ p->next = 0; }
]?
')'
[ ':' qualident(D_TYPE|D_HTYPE|D_HIDDEN, &df, "type", (struct node **) 0)
[ ':' qualident(D_TYPE, &df, "type", (struct node **) 0)
{ *ptp = df->df_type; }
]?
;

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

@ -81,19 +81,21 @@ struct def { /* list of definitions for a name */
#define D_IMPORT 0x0080 /* an imported definition */
#define D_PROCHEAD 0x0100 /* a procedure heading in a definition module */
#define D_HIDDEN 0x0200 /* a hidden type */
#define D_HTYPE 0x0400 /* definition of a hidden type seen */
#define D_FORWARD 0x0800 /* not yet defined */
#define D_UNDEF_IMPORT 0x1000 /* imported from an undefined name */
#define D_FORWMODULE 0x2000 /* module must be declared later */
#define D_ERROR 0x4000 /* a compiler generated definition for an
undefined variable
*/
#define D_ISTYPE (D_HIDDEN|D_TYPE)
#define is_type(dfx) ((dfx)->df_kind & D_ISTYPE)
char df_flags;
#define D_ADDRESS 0x01 /* set if address was taken */
#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_VARPAR 0x08 /* set if it is a VAR parameter */
#define D_VALPAR 0x10 /* set if it is a value parameter */
#define D_REFERRED 0x08 /* set if it is referred to */
#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 */
#define D_QEXPORTED 0x80 /* set if qualified exported */
struct type *df_type;

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

@ -18,6 +18,7 @@ static char *RcsId = "$Header$";
#include "scope.h"
#include "LLlex.h"
#include "node.h"
#include "Lpars.h"
struct def *h_def; /* Pointer to free list of def structures */
@ -80,7 +81,7 @@ define(id, scope, kind)
switch(df->df_kind) {
case D_HIDDEN:
if (kind == D_TYPE && !DefinitionModule) {
df->df_kind = D_HTYPE;
df->df_kind = D_TYPE;
return df;
}
break;
@ -94,6 +95,7 @@ define(id, scope, kind)
FreeNode(df->for_node);
df->mod_vis = df->for_vis;
df->df_kind = kind;
DefInFront(df);
return df;
}
break;
@ -241,9 +243,9 @@ df->df_idf->id_text);
else if (df1 && df1->df_kind == D_HIDDEN) {
if (df->df_kind == D_TYPE) {
if (df->df_type->tp_fund != T_POINTER) {
error("Opaque type \"%s\" is not a pointer type", df->df_idf->id_text);
error("opaque type \"%s\" is not a pointer type", df->df_idf->id_text);
}
df->df_kind = D_HTYPE;
df->df_kind = D_TYPE;
df1->df_kind = D_IMPORT;
df1->imp_def = df;
continue;
@ -436,8 +438,10 @@ DeclProc(type)
module. Create a def structure for it (if neccessary)
*/
register struct def *df;
extern char *sprint(), *Malloc(), *strcpy();
static int nmcount = 0;
extern char *Malloc();
extern char *strcpy();
extern char *sprint();
char buf[256];
assert(type & (D_PROCEDURE | D_PROCHEAD));
@ -462,6 +466,7 @@ DeclProc(type)
open_scope(OPENSCOPE);
CurrentScope->sc_name = df->for_name;
df->prc_vis = CurrVis;
DefInFront(df);
}
else {
df = define(dot.TOK_IDF, CurrentScope, type);
@ -492,6 +497,46 @@ InitProc(nd, df)
/* Keep it this way, or really create a procedure out of it??? */
}
AddModule(id)
struct idf *id;
{
/* Add the name of a module to the Module list. This list is
maintained to create the initialization routine of the
program/implementation module currently defined.
*/
static struct node *nd_end; /* to remember end of list */
register struct node *n;
extern struct node *Modules;
n = MkNode(Name, NULLNODE, NULLNODE, &dot);
n->nd_IDF = id;
n->nd_symb = IDENT;
if (nd_end) nd_end->next = n;
nd_end = n;
if (!Modules) Modules = n;
}
DefInFront(df)
register struct def *df;
{
/* Put definition "df" in front of the list of definitions
in its scope.
This is neccessary because in some cases the order in this
list is important.
*/
register struct def *df1;
if (df->df_scope->sc_def != df) {
df1 = df->df_scope->sc_def;
while (df1 && df1->df_nextinscope != df) {
df1 = df1->df_nextinscope;
}
if (df1) df1->df_nextinscope = df->df_nextinscope;
df->df_nextinscope = df->df_scope->sc_def;
df->df_scope->sc_def = df;
}
}
#ifdef DEBUG
PrDef(df)
register struct def *df;

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

@ -52,7 +52,9 @@ GetDefinitionModule(id)
We may have to read the definition module itself.
*/
struct def *df;
static int level;
level++;
df = lookup(id, GlobalScope);
if (!df) {
/* Read definition module. Make an exception for SYSTEM.
@ -63,10 +65,19 @@ GetDefinitionModule(id)
else {
GetFile(id->id_text);
DefModule();
if (level == 1) {
/* The module is directly imported by the
currently defined module, so we have to
remember its name because we have to call
its initialization routine
*/
AddModule(id);
}
}
df = lookup(id, GlobalScope);
}
assert(df != 0 && df->df_kind == D_MODULE);
level--;
return df;
}

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

@ -232,6 +232,7 @@ CodeVarDesig(df, ds)
CodeConst(df->var_off, pointer_size);
ds->dsg_kind = DSG_PLOADED;
ds->dsg_offset = 0;
df->df_flags |= D_NOREG;
return;
}
@ -242,6 +243,7 @@ CodeVarDesig(df, ds)
ds->dsg_name = df->var_name;
ds->dsg_offset = 0;
ds->dsg_kind = DSG_FIXED;
df->df_flags |= D_NOREG;
return;
}
@ -254,6 +256,7 @@ CodeVarDesig(df, ds)
ds->dsg_name = &(sc->sc_name[1]);
ds->dsg_offset = df->var_off;
ds->dsg_kind = DSG_FIXED;
df->df_flags |= D_NOREG;
return;
}
@ -278,6 +281,7 @@ CodeVarDesig(df, ds)
else C_lxl((arith) (proclevel - sc->sc_level));
ds->dsg_kind = DSG_PLOADED;
ds->dsg_offset = df->var_off;
df->df_flags |= D_NOREG;
return;
}
@ -304,6 +308,7 @@ CodeDesig(nd, ds)
case Def: {
register struct def *df = nd->nd_def;
df->df_flags |= D_USED;
switch(df->df_kind) {
case D_FIELD:
CodeFieldDesig(df, ds);
@ -335,14 +340,16 @@ CodeDesig(nd, ds)
*ds = InitDesig;
CodeExpr(nd->nd_right, ds, NO_LABEL, NO_LABEL);
CodeValue(ds, nd->nd_right->nd_type->tp_size);
CodeCoercion(nd->nd_right->nd_type, int_type);
if (nd->nd_right->nd_type->tp_size > word_size) {
CodeCoercion(nd->nd_right->nd_type, int_type);
}
if (IsConformantArray(nd->nd_left->nd_type)) {
/* ??? */
}
else {
/* load address of descriptor
*/
/* ??? */
C_lae_dlb(nd->nd_left->nd_type->arr_descr, (arith) 0);
}
ds->dsg_kind = DSG_INDEXED;
break;

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

@ -67,27 +67,23 @@ EnterIdList(idlist, kind, flags, type, scope, addr)
int xalign = type->tp_align;
if (xalign < word_align && kind != D_FIELD) {
/* variables are at least word aligned
*/
xalign = word_align;
}
if (*addr >= 0) {
if (scope->sc_level) {
if (scope->sc_level && kind != D_FIELD) {
/* alignment of parameters is on
word boundaries. We cannot do any
better, because we don't know the
alignment of the stack pointer when
starting to push parameters
*/
off = *addr;
*addr = align(off, word_align);
}
else {
/* for global variables we can honour
the alignment requirements totally.
*/
off = align(*addr, xalign);
*addr = off + type->tp_size;
xalign = word_align;
}
off = align(*addr, xalign);
*addr = off + type->tp_size;
}
else {
off = -align(-*addr-type->tp_size, xalign);

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

@ -25,6 +25,7 @@ number(struct node **p;)
struct type *tp;
} :
[
%default
INTEGER { tp = numtype; }
|
REAL { tp = real_type; }
@ -46,7 +47,7 @@ qualident(int types; struct def **pdf; char *str; struct node **p;)
{ if (types) {
df = ill_df;
if (chk_designator(nd, 0)) {
if (chk_designator(nd, 0, D_REFERRED)) {
if (nd->nd_class != Def) {
node_error(nd, "%s expected", str);
}
@ -113,9 +114,7 @@ expression(struct node **pnd;)
SimpleExpression(pnd)
[
/* relation */
[ '=' | '#' | UNEQUAL | '<' | LESSEQUAL | '>' |
GREATEREQUAL | IN
]
[ '=' | '#' | '<' | LESSEQUAL | '>' | GREATEREQUAL | IN ]
{ *pnd = MkNode(Oper, *pnd, NULLNODE, &dot); }
SimpleExpression(&((*pnd)->nd_right))
]?
@ -123,7 +122,7 @@ expression(struct node **pnd;)
/* Inline in expression
relation:
'=' | '#' | UNEQUAL | '<' | LESSEQUAL | '>' | GREATEREQUAL | IN
'=' | '#' | '<' | LESSEQUAL | '>' | GREATEREQUAL | IN
;
*/
@ -184,9 +183,7 @@ factor(struct node **p;)
]?
|
bare_set(&nd)
{ nd->nd_left = *p;
*p = nd;
}
{ nd->nd_left = *p; *p = nd; }
]
|
bare_set(p)
@ -200,9 +197,9 @@ factor(struct node **p;)
tp = charc_type;
i = *(dot.TOK_STR) & 0377;
free((char *) dot.tk_data.tk_str);
free(dot.TOK_STR);
dot.TOK_INT = i;
free((char *) dot.tk_data.tk_str);
(*p)->nd_INT = i;
}
else tp = standard_type(T_STRING, 1, dot.TOK_SLE);
(*p)->nd_type = tp;

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

@ -23,13 +23,14 @@ static char *RcsId = "$Header$";
#include "tokenname.h"
#include "node.h"
int state; /* either IMPLEMENTATION or PROGRAM */
char options[128];
int DefinitionModule;
int SYSTEMModule = 0;
char *ProgName;
extern int err_occurred;
char *DEFPATH[NDIRS+1];
struct def *Defined;
extern int err_occurred;
main(argc, argv)
char *argv[];
@ -93,6 +94,7 @@ Compile(src, dst)
C_magic();
C_ms_emx(word_size, pointer_size);
CompUnit();
close_scope(SC_REVERSE);
if (err_occurred) {
C_close();
return 0;

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

@ -17,3 +17,4 @@ extern struct def *Defined;
compilation
*/
extern char *DEFPATH[]; /* search path for DEFINITION MODULE's */
extern int state; /* either IMPLEMENTATION or PROGRAM */

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

@ -31,7 +31,7 @@ MkNode(class, left, right, token)
nd->nd_right = right;
nd->nd_token = *token;
nd->nd_class = class;
nd->nd_type = NULLTYPE;
nd->nd_type = error_type;
DO_DEBUG(4,(debug("Create node:"), PrNode(nd)));
return nd;
}

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

@ -231,7 +231,7 @@ Semicolon:
{ warning("; expected"); }
;
ProgramModule(int state;)
ProgramModule
{
struct idf *id;
struct def *GetDefinitionModule();
@ -267,16 +267,15 @@ ProgramModule(int state;)
'.'
;
Module
{
int state = PROGRAM;
} :
Module:
DefinitionModule
|
[
IMPLEMENTATION { state = IMPLEMENTATION; }
]?
ProgramModule(state)
|
{ state = PROGRAM; }
]
ProgramModule
;
CompilationUnit:

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

@ -166,7 +166,7 @@ rem_forwards(fo)
while (f = fo) {
df = lookfor(&(f->fo_tok), CurrVis, 1);
if (!(df->df_kind & (D_TYPE|D_HTYPE|D_ERROR))) {
if (!(df->df_kind & (D_TYPE|D_ERROR))) {
node_error(&(f->fo_tok), "identifier \"%s\" not a type",
df->df_idf->id_text);
}

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

@ -24,7 +24,6 @@ struct tokenname tkspec[] = { /* the names of the special tokens */
};
struct tokenname tkcomp[] = { /* names of the composite tokens */
{UNEQUAL, "<>"},
{LESSEQUAL, "<="},
{GREATEREQUAL, ">="},
{UPTO, ".."},

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

@ -16,7 +16,7 @@ struct enume {
label en_rck; /* Label of range check descriptor */
#define enm_enums tp_value.tp_enum.en_enums
#define enm_ncst tp_value.tp_enum.en_ncst
#define enm_rck tp_value.tp_enum.enm_rck
#define enm_rck tp_value.tp_enum.en_rck
};
struct subrange {
@ -68,9 +68,10 @@ struct type {
#define T_ARRAY 0x2000
#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)
#define T_INDEX (T_ENUMERATION|T_CHAR|T_SUBRANGE)
#define T_DISCRETE (T_INDEX|T_INTORCARD)
#define T_PRCRESULT (T_DISCRETE|T_REAL|T_POINTER|T_WORD)
int tp_align; /* alignment requirement of this type */
arith tp_size; /* size of this type */
union {
@ -131,3 +132,7 @@ struct type
#define NULLTYPE ((struct type *) 0)
#define IsConformantArray(tpx) ((tpx)->tp_fund == T_ARRAY && (tpx)->next == 0)
#define bounded(tpx) ((tpx)->tp_fund & T_INDEX)
#define complex(tpx) ((tpx)->tp_fund & (T_RECORD|T_ARRAY))
#define returntype(tpx) (((tpx)->tp_fund & T_PRCRESULT) ||\
((tpx)->tp_fund == T_SET && (tpx)->tp_size <= dword_size))

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

@ -61,6 +61,8 @@ struct paramlist *h_paramlist;
struct type *h_type;
extern label data_label();
struct type *
create_type(fund)
register int fund;
@ -117,7 +119,7 @@ construct_type(fund, tp)
break;
default:
assert(0);
crash("funny type constructor");
}
return dtp;
@ -325,6 +327,52 @@ subr_type(lb, ub)
return res;
}
label
getrck(tp)
register struct type *tp;
{
/* generate a range check descriptor for type "tp" when
neccessary. Return its label
*/
assert(bounded(tp));
if (tp->tp_fund == T_SUBRANGE) {
if (tp->sub_rck == (label) 0) {
tp->sub_rck = data_label();
C_df_dlb(tp->sub_rck);
C_rom_cst(tp->sub_lb);
C_rom_cst(tp->sub_ub);
}
return tp->sub_rck;
}
if (tp->enm_rck == (label) 0) {
tp->enm_rck = data_label();
C_df_dlb(tp->enm_rck);
C_rom_cst((arith) 0);
C_rom_cst((arith) (tp->enm_ncst - 1));
}
return tp->enm_rck;
}
getbounds(tp, plo, phi)
register struct type *tp;
arith *plo, *phi;
{
/* Get the bounds of a bounded type
*/
assert(bounded(tp));
if (tp->tp_fund == T_SUBRANGE) {
*plo = tp->sub_lb;
*phi = tp->sub_ub;
}
else {
*plo = 0;
*phi = tp->enm_ncst - 1;
}
}
struct type *
set_type(tp)
struct type *tp;
@ -385,18 +433,30 @@ ArraySizes(tp)
/* find out HIGH, LOW and size of ARRAY
*/
tp->arr_descr = data_label();
C_df_dlb(tp->arr_descr);
switch(index_type->tp_fund) {
case T_SUBRANGE:
tp->tp_size = elem_size *
(index_type->sub_ub - index_type->sub_lb + 1);
C_rom_cst(index_type->sub_lb);
C_rom_cst(index_type->sub_ub - index_type->sub_lb);
break;
case T_CHAR:
case T_ENUMERATION:
tp->tp_size = elem_size * index_type->enm_ncst;
C_rom_cst((arith) 0);
C_rom_cst((arith) (index_type->enm_ncst - 1));
break;
default:
assert(0);
crash("Funny index type");
}
C_rom_cst(elem_size);
/* ??? overflow checking ???
*/
}

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

@ -23,14 +23,17 @@ static char *RcsId = "$Header$";
#include "Lpars.h"
#include "desig.h"
#include "f_info.h"
#include "idf.h"
extern arith align();
extern arith NewPtr();
extern arith NewInt();
extern int proclevel;
static label instructionlabel;
static char return_expr_occurred;
static struct type *func_type;
struct withdesig *WithDesigs;
struct node *Modules;
label
text_label()
@ -88,7 +91,9 @@ WalkModule(module)
/* WHY ??? because we generated an INA for it ??? */
C_df_dnam(&(sc->sc_name[1]));
size = align(size, word_align);
C_bss_cst(size, (arith) 0, 0);
C_exp(sc->sc_name);
}
else if (CurrVis == Defined->mod_vis) {
/* This module is the module currently being compiled.
@ -98,10 +103,14 @@ WalkModule(module)
while (df) {
if (df->df_kind == D_VARIABLE) {
C_df_dnam(df->var_name);
C_bss_cst(df->df_type->tp_size, (arith) 0, 0);
C_bss_cst(
align(df->df_type->tp_size, word_align),
(arith) 0, 0);
}
df = df->df_nextinscope;
}
if (state == PROGRAM) C_exp("main");
else C_exp(sc->sc_name);
}
/* Now, walk through it's local definitions
@ -115,26 +124,55 @@ WalkModule(module)
sc->sc_off = 0;
instructionlabel = 2;
func_type = 0;
C_pro_narg(sc->sc_name);
C_pro_narg(state == PROGRAM ? "main" : sc->sc_name);
DoProfil();
if (CurrVis == Defined->mod_vis) {
/* Body of implementation or program module.
Call initialization routines of imported modules.
Also prevent recursive calls of this one.
*/
label l1 = data_label(), l2 = text_label();
struct node *nd;
/* we don't actually prevent recursive calls, but do nothing
if called recursively
*/
C_df_dlb(l1);
C_bss_cst(word_size, (arith) 0, 1);
C_loe_dlb(l1, (arith) 0);
C_zeq(l2);
C_ret((arith) 0);
C_df_ilb(l2);
C_loc((arith) 1);
C_ste_dlb(l1, (arith) 0);
nd = Modules;
while (nd) {
C_cal(nd->nd_IDF->id_text);
nd = nd->next;
}
}
MkCalls(sc->sc_def);
proclevel++;
WalkNode(module->mod_body, (label) 0);
C_df_ilb((label) 1);
C_ret(0);
C_ret((arith) 0);
C_end(-sc->sc_off);
proclevel--;
TmpClose();
CurrVis = vis;
}
WalkProcedure(procedure)
struct def *procedure;
register struct def *procedure;
{
/* Walk through the definition of a procedure and all its
local definitions
*/
struct scopelist *vis = CurrVis;
register struct scope *sc;
register struct type *res_type;
proclevel++;
CurrVis = procedure->prc_vis;
@ -152,16 +190,19 @@ WalkProcedure(procedure)
MkCalls(sc->sc_def);
return_expr_occurred = 0;
instructionlabel = 2;
func_type = procedure->df_type->next;
func_type = res_type = procedure->df_type->next;
if (! returntype(res_type)) {
node_error(procedure->prc_body, "illegal result type");
}
WalkNode(procedure->prc_body, (label) 0);
C_df_ilb((label) 1);
if (func_type) {
if (res_type) {
if (! return_expr_occurred) {
node_error(procedure->prc_body,"function procedure does not return a value");
}
C_ret((int) align(func_type->tp_size, word_align));
C_ret(align(res_type->tp_size, word_align));
}
else C_ret(0);
else C_ret((arith) 0);
C_end(-sc->sc_off);
TmpClose();
CurrVis = vis;
@ -195,6 +236,7 @@ MkCalls(df)
if (df->df_kind == D_MODULE) {
C_lxl((arith) 0);
C_cal(df->mod_vis->sc_scope->sc_name);
C_asp(pointer_size);
}
df = df->df_nextinscope;
}
@ -246,20 +288,8 @@ WalkStat(nd, lab)
assert(nd->nd_class == Stat);
switch(nd->nd_symb) {
case BECOMES: {
struct desig ds;
WalkExpr(right, NO_LABEL, NO_LABEL);
ds = Desig;
WalkDesignator(left); /* May we do it in this order??? */
if (! TstAssCompat(left->nd_type, right->nd_type)) {
node_error(nd, "type incompatibility in assignment");
break;
}
CodeAssign(nd, &ds, pds);
}
case BECOMES:
DoAssign(nd, left, right, 0);
break;
case IF:
@ -327,8 +357,61 @@ WalkStat(nd, lab)
}
case FOR:
/* ??? */
WalkNode(right, lab);
{
arith tmp = 0;
struct node *fnd;
label l1 = instructionlabel++;
label l2 = instructionlabel++;
arith incr = 1;
arith size;
assert(left->nd_symb == TO);
assert(left->nd_left->nd_symb == BECOMES);
DoAssign(left->nd_left,
left->nd_left->nd_left,
left->nd_left->nd_right, 1);
fnd = left->nd_right;
if (fnd->nd_symb == BY) {
incr = fnd->nd_left->nd_INT;
fnd = fnd->nd_right;
}
if (! chk_expr(fnd)) return;
size = fnd->nd_type->tp_size;
if (fnd->nd_class != Value) {
*pds = InitDesig;
CodeExpr(fnd, pds, NO_LABEL, NO_LABEL);
CodeValue(pds, size);
tmp = NewInt();
C_stl(tmp);
}
if (!TstCompat(left->nd_left->nd_left->nd_type,
fnd->nd_type)) {
node_error(fnd, "type incompatibility in limit of FOR loop");
break;
}
C_bra(l1);
C_df_ilb(l2);
WalkNode(right, lab);
*pds = InitDesig;
C_loc(incr);
CodeDesig(left->nd_left->nd_left, pds);
CodeValue(pds, size);
C_adi(int_size);
*pds = InitDesig;
CodeDesig(left->nd_left->nd_left, pds);
CodeStore(pds, size);
C_df_ilb(l1);
*pds = InitDesig;
CodeDesig(left->nd_left->nd_left, pds);
CodeValue(pds, size);
if (tmp) C_lol(tmp); else C_loc(fnd->nd_INT);
if (incr > 0) {
C_ble(l2);
}
else C_bge(l2);
if (tmp) FreeInt(tmp);
}
break;
case WITH:
@ -358,7 +441,7 @@ WalkStat(nd, lab)
pds->dsg_kind = DSG_PFIXED;
/* the record is indirectly available */
}
wds.w_desig = Desig;
wds.w_desig = *pds;
link.sc_scope = wds.w_scope;
link.next = CurrVis;
CurrVis = &link;
@ -432,10 +515,47 @@ WalkDesignator(nd)
DO_DEBUG(1, (DumpTree(nd), print("\n")));
if (! chk_designator(nd, DESIGNATOR|VARIABLE)) return;
if (! chk_designator(nd, DESIGNATOR|VARIABLE, D_DEFINED)) return;
Desig = InitDesig;
CodeDesig(nd, &Desig);
}
DoAssign(nd, left, right, forloopass)
struct node *nd;
register struct node *left, *right;
{
/* May we do it in this order (expression first) ??? */
struct desig ds;
WalkExpr(right, NO_LABEL, NO_LABEL);
if (! chk_designator(left, DESIGNATOR|VARIABLE, D_DEFINED)) return;
if (forloopass) {
if (! TstCompat(left->nd_type, right->nd_type)) {
node_error(nd, "type incompatibility in FOR loop");
return;
}
/* Test if the left hand side may be a for loop variable ??? */
}
else if (! TstAssCompat(left->nd_type, right->nd_type)) {
node_error(nd, "type incompatibility in assignment");
return;
}
if (complex(right->nd_type)) {
CodeAddress(&Desig);
}
else {
CodeValue(&Desig, right->nd_type->tp_size);
CheckAssign(left->nd_type, right->nd_type);
}
ds = Desig;
Desig = InitDesig;
CodeDesig(left, &Desig);
CodeAssign(nd, &ds, &Desig);
}
#ifdef DEBUG