if (nch == '=') {
return tk->tk_symb = LESSEQUAL;
}
- else
- if (nch == '>') {
- return tk->tk_symb = '#';
- }
PushBack(nch);
return tk->tk_symb = ch;
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>
#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);
}
CC = cc
GEN = LLgen
GENOPTIONS =
-PROFILE =
+PROFILE =
CFLAGS = $(PROFILE) $(INCLUDES)
LFLAGS = $(PROFILE)
LOBJ = tokenfile.o program.o declar.o expression.o statement.o
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
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
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
*/
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++) {
/* 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;
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) &&
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) &&
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);
struct def *df;
register struct node *nd;
arith *set;
+ unsigned size;
assert(expp->nd_symb == SET);
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;
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 == ',');
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
}
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;
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);
*/
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;
{
/* 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;
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;
}
}
int
-chk_designator(expp, flag)
+chk_designator(expp, flag, dflags)
register struct node *expp;
{
/* Find the name indicated by "expp", starting from the current
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;
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;
}
}
+ df->df_flags |= dflags;
+
return 1;
}
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)
||
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;
}
case '=':
case '#':
- case UNEQUAL:
case GREATEREQUAL:
case LESSEQUAL:
case '<':
case T_POINTER:
if (chk_address(tpl, tpr) ||
expp->nd_symb == '=' ||
- expp->nd_symb == UNEQUAL ||
expp->nd_symb == '#') return 1;
break;
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;
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;
}
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;
}
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;
{
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)) {
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)
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);
}
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;
}
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)
}
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;
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 */
/* ??? */
}
-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)
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");
}
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 '&':
case '=':
C_zeq(lbl);
break;
- case UNEQUAL:
case '#':
C_zne(lbl);
break;
case '=':
C_teq();
break;
- case UNEQUAL:
case '#':
C_tne();
break;
Des = InitDesig;
CodeExpr(nd, &Des, NO_LABEL, NO_LABEL);
- CodeValue(nd, word_size);
+ CodeValue(&Des, word_size);
C_set(tp->tp_size);
}
}
o1 = !o1;
break;
default:
- assert(0);
+ crash("(cstunary)");
}
expp->nd_class = Value;
expp->nd_token = expp->nd_right->nd_token;
);
}
else
- o1 = o1 < o2;
+ o1 = (o1 < o2);
break;
case '>':
);
}
else
- o1 = o1 > o2;
+ o1 = (o1 > o2);
break;
case LESSEQUAL:
if (uns) {
);
}
else
- o1 = o1 <= o2;
+ o1 = (o1 <= o2);
break;
case GREATEREQUAL:
if (uns) {
);
}
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);
register struct node *expp;
{
register arith *set1 = 0, *set2;
+ arith *resultset = 0;
register int setsize, j;
assert(expp->nd_right->nd_class == Set);
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;
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);
else CutSize(expp);
break;
default:
- assert(0);
+ crash("(cstcall)");
}
FreeNode(expr);
FreeNode(expp->nd_left);
]?
')'
{ *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;
}
]?
} :
[ 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;
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;
}
;
{
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; }
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");
}
}
;
'[' ConstExpression(&nd1)
UPTO ConstExpression(&nd2)
']'
- { *ptp = subr_type(nd1, nd2); }
+ { *ptp = subr_type(nd1, nd2);
+ }
;
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;
}
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
{ 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;
]
|
/* 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;
/* 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",
{ 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; }
]?
;
#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;
#include "scope.h"
#include "LLlex.h"
#include "node.h"
+#include "Lpars.h"
struct def *h_def; /* Pointer to free list of def structures */
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;
FreeNode(df->for_node);
df->mod_vis = df->for_vis;
df->df_kind = kind;
+ DefInFront(df);
return df;
}
break;
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;
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));
open_scope(OPENSCOPE);
CurrentScope->sc_name = df->for_name;
df->prc_vis = CurrVis;
+ DefInFront(df);
}
else {
df = define(dot.TOK_IDF, CurrentScope, type);
/* 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;
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.
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;
}
CodeConst(df->var_off, pointer_size);
ds->dsg_kind = DSG_PLOADED;
ds->dsg_offset = 0;
+ df->df_flags |= D_NOREG;
return;
}
ds->dsg_name = df->var_name;
ds->dsg_offset = 0;
ds->dsg_kind = DSG_FIXED;
+ df->df_flags |= D_NOREG;
return;
}
ds->dsg_name = &(sc->sc_name[1]);
ds->dsg_offset = df->var_off;
ds->dsg_kind = DSG_FIXED;
+ df->df_flags |= D_NOREG;
return;
}
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;
}
case Def: {
register struct def *df = nd->nd_def;
+ df->df_flags |= D_USED;
switch(df->df_kind) {
case D_FIELD:
CodeFieldDesig(df, 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;
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);
struct type *tp;
} :
[
+ %default
INTEGER { tp = numtype; }
|
REAL { tp = real_type; }
{ 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);
}
SimpleExpression(pnd)
[
/* relation */
- [ '=' | '#' | UNEQUAL | '<' | LESSEQUAL | '>' |
- GREATEREQUAL | IN
- ]
+ [ '=' | '#' | '<' | LESSEQUAL | '>' | GREATEREQUAL | IN ]
{ *pnd = MkNode(Oper, *pnd, NULLNODE, &dot); }
SimpleExpression(&((*pnd)->nd_right))
]?
/* Inline in expression
relation:
- '=' | '#' | UNEQUAL | '<' | LESSEQUAL | '>' | GREATEREQUAL | IN
+ '=' | '#' | '<' | LESSEQUAL | '>' | GREATEREQUAL | IN
;
*/
]?
|
bare_set(&nd)
- { nd->nd_left = *p;
- *p = nd;
- }
+ { nd->nd_left = *p; *p = nd; }
]
|
bare_set(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;
#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[];
C_magic();
C_ms_emx(word_size, pointer_size);
CompUnit();
+ close_scope(SC_REVERSE);
if (err_occurred) {
C_close();
return 0;
compilation
*/
extern char *DEFPATH[]; /* search path for DEFINITION MODULE's */
+extern int state; /* either IMPLEMENTATION or PROGRAM */
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;
}
{ warning("; expected"); }
;
-ProgramModule(int state;)
+ProgramModule
{
struct idf *id;
struct def *GetDefinitionModule();
'.'
;
-Module
-{
- int state = PROGRAM;
-} :
+Module:
DefinitionModule
|
[
IMPLEMENTATION { state = IMPLEMENTATION; }
- ]?
- ProgramModule(state)
+ |
+ { state = PROGRAM; }
+ ]
+ ProgramModule
;
CompilationUnit:
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);
}
};
struct tokenname tkcomp[] = { /* names of the composite tokens */
- {UNEQUAL, "<>"},
{LESSEQUAL, "<="},
{GREATEREQUAL, ">="},
{UPTO, ".."},
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 {
#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 {
#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))
struct type *h_type;
+extern label data_label();
+
struct type *
create_type(fund)
register int fund;
break;
default:
- assert(0);
+ crash("funny type constructor");
}
return dtp;
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;
/* 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 ???
*/
}
#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()
/* 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.
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
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;
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;
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;
}
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:
}
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:
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;
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
public / ack.git / commitdiff