From: ceriel Date: Wed, 9 Apr 1986 18:14:49 +0000 (+0000) Subject: safety commit X-Git-Tag: release-5-5~5312 X-Git-Url: https://git.ndcode.org/public/gitweb.cgi?a=commitdiff_plain;h=d1a21121633a8be238934e0b9d0fd2c30c70814c;p=ack.git safety commit --- diff --git a/lang/m2/comp/LLlex.h b/lang/m2/comp/LLlex.h index 92bc5979e..db49e6b9d 100644 --- a/lang/m2/comp/LLlex.h +++ b/lang/m2/comp/LLlex.h @@ -16,6 +16,8 @@ struct token { struct string tk_str; /* STRING */ arith tk_int; /* INTEGER */ char *tk_real; /* REAL */ + arith *tk_set; /* only used in parse tree node */ + struct def *tk_def; /* only used in parse tree node */ } tk_data; }; diff --git a/lang/m2/comp/Makefile b/lang/m2/comp/Makefile index 2dee7e1a1..74969ac11 100644 --- a/lang/m2/comp/Makefile +++ b/lang/m2/comp/Makefile @@ -91,7 +91,7 @@ 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 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 -chk_expr.o: LLlex.h Lpars.h def.h idf.h node.h scope.h type.h +chk_expr.o: LLlex.h Lpars.h const.h def.h idf.h node.h scope.h standards.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 def.h idf.h misc.h node.h scope.h type.h diff --git a/lang/m2/comp/chk_expr.c b/lang/m2/comp/chk_expr.c index 491796161..3b0cd8ba6 100644 --- a/lang/m2/comp/chk_expr.c +++ b/lang/m2/comp/chk_expr.c @@ -7,6 +7,7 @@ static char *RcsId = "$Header$"; #include #include #include +#include #include "idf.h" #include "type.h" #include "def.h" @@ -14,6 +15,8 @@ static char *RcsId = "$Header$"; #include "node.h" #include "Lpars.h" #include "scope.h" +#include "const.h" +#include "standards.h" int chk_expr(expp, const) @@ -60,10 +63,13 @@ int chk_set(expp, const) register struct node *expp; { + /* Check the legality of a SET aggregate, and try to evaluate it + compile time. Unfortunately this is all rather complicated. + */ struct type *tp; struct def *df; register struct node *nd; - extern struct def *findname(); + arith *set; assert(expp->nd_symb == SET); @@ -72,7 +78,9 @@ chk_set(expp, const) if (expp->nd_left) { /* A type was given. Check it out */ - df = findname(expp->nd_left); + (void) findname(expp->nd_left); + assert(expp->nd_left->nd_class == Def); + df = expp->nd_left->nd_def; if ((df->df_kind != D_TYPE && df->df_kind != D_ERROR) || (df->df_type->tp_fund != SET)) { node_error(expp, "Illegal set type"); @@ -82,48 +90,79 @@ chk_set(expp, const) } else tp = bitset_type; - /* Now check the elements given + /* Now check the elements given, and try to compute a constant set. */ + set = (arith *) Malloc(tp->tp_size * sizeof(arith) / wrd_size); nd = expp->nd_right; while (nd) { assert(nd->nd_class == Link && nd->nd_symb == ','); - if (!chk_el(nd->nd_left, const, tp->next, 0)) return 0; + if (!chk_el(nd->nd_left, const, tp->next, &set)) return 0; nd = nd->nd_right; } + expp->nd_type = tp; + assert(!const || set); + if (set) { + /* Yes, in was a constant set, and we managed to compute it! + */ + expp->nd_class = Set; + expp->nd_set = set; + FreeNode(expp->nd_left); + FreeNode(expp->nd_right); + expp->nd_left = expp->nd_right = 0; + } return 1; } int -chk_el(expp, const, tp, level) - struct node *expp; +chk_el(expp, const, tp, set) + register struct node *expp; struct type *tp; + arith **set; { /* Check elements of a set. This routine may call itself - recursively, but only once. + recursively. + Also try to compute the set! */ if (expp->nd_class == Link && expp->nd_symb == UPTO) { - /* { ... , expr1 .. expr2, ... } */ - if (level) { - node_error(expp, "Illegal set element"); - return 0; - } - if (!chk_el(expp->nd_left, const, tp, 1) || - !chk_el(expp->nd_right, const, tp, 1)) { + /* { ... , expr1 .. expr2, ... } + First check expr1 and expr2, and try to compute them. + */ + if (!chk_el(expp->nd_left, const, tp, set) || + !chk_el(expp->nd_right, const, tp, set)) { return 0; } if (expp->nd_left->nd_class == Value && expp->nd_right->nd_class == Value) { + /* We have a constant range. Put all elements in the + set + */ + register int i; + if (expp->nd_left->nd_INT > expp->nd_right->nd_INT) { node_error(expp, "Lower bound exceeds upper bound in range"); - return 0; + return rem_set(set); } + + if (*set) for (i = expp->nd_left->nd_INT + 1; + i < expp->nd_right->nd_INT; i++) { + (*set)[i/wrd_bits] |= (1 << (i % wrd_bits)); + } + } + else if (*set) { + free(*set); + *set = 0; } return 1; } - if (!chk_expr(expp, const)) return 0; + + /* Here, a single element is checked + */ + if (!chk_expr(expp, const)) { + return rem_set(set); + } if (!TstCompat(tp, expp->nd_type)) { node_error(expp, "Set element has incompatible type"); - return 0; + return rem_set(set); } if (expp->nd_class == Value) { if ((tp->tp_fund != ENUMERATION && @@ -133,24 +172,104 @@ node_error(expp, "Lower bound exceeds upper bound in range"); (expp->nd_INT < 0 || expp->nd_INT > tp->enm_ncst)) ) { node_error(expp, "Set element out of range"); -#ifdef DEBUG - debug("%d (%d, %d)", (int) expp->nd_INT, (int) tp->sub_lb, (int) tp->sub_ub); -#endif - return 0; + return rem_set(set); } + if (*set) (*set)[expp->nd_INT/wrd_bits] |= (1 << (expp->nd_INT%wrd_bits)); } return 1; } +int +rem_set(set) + arith **set; +{ + /* This routine is only used for error exits of chk_el. + It frees the set indicated by "set", and returns 0. + */ + if (*set) { + free((char *) *set); + *set = 0; + } + return 0; +} + int chk_call(expp, const) register struct node *expp; { - /* ??? */ - return 1; + register struct type *tp; + register struct node *left; + + expp->nd_type = error_type; + (void) findname(expp->nd_left); + left = expp->nd_left; + tp = left->nd_type; + + if (tp == error_type) return 0; + if (left->nd_class == Def && + (left->nd_def->df_kind & (D_HTYPE|D_TYPE|D_HIDDEN))) { + /* A type cast. This is of course not portable. + No runtime action. Remove it. + */ + if (!expp->nd_right || + (expp->nd_right->nd_symb == ',')) { +node_error(expp, "Only one parameter expected in type cast"); + return 0; + } + if (! chk_expr(expp->nd_right, const)) return 0; + if (expp->nd_right->nd_type->tp_size != + left->nd_type->tp_size) { +node_error(expp, "Size of type in type cast does not match size of operand"); + return 0; + } + expp->nd_right->nd_type = left->nd_type; + left = expp->nd_right; + FreeNode(expp->nd_left); + *expp = *(expp->nd_right); + left->nd_left = left->nd_right = 0; + FreeNode(left); + return 1; + } + + if ((left->nd_class == Def && left->nd_def->df_kind == D_PROCEDURE) || + tp->tp_fund == PROCVAR) { + /* A procedure call. it may also be a call to a + standard procedure + */ + if (tp == std_type) { + assert(left->nd_class == Def); + switch(left->nd_def->df_value.df_stdname) { + case S_ABS: + case S_CAP: + case S_CHR: + case S_FLOAT: + case S_HIGH: + case S_MAX: + case S_MIN: + case S_ODD: + case S_ORD: + case S_SIZE: + case S_TRUNC: + case S_VAL: + break; + case S_DEC: + case S_INC: + case S_HALT: + case S_EXCL: + case S_INCL: + expp->nd_type = 0; + break; + default: + assert(0); + } + return 1; + } + return 1; + } + node_error(expp->nd_left, "procedure, type, or function expected"); + return 0; } -struct def * findname(expp) register struct node *expp; { @@ -159,41 +278,66 @@ findname(expp) */ register struct def *df; struct def *lookfor(); - register struct node *nd; + register struct type *tp; int scope; int module; + expp->nd_type = error_type; if (expp->nd_class == Name) { - return lookfor(expp, CurrentScope, 1); + expp->nd_def = lookfor(expp, CurrentScope, 1); + expp->nd_class = Def; + expp->nd_type = expp->nd_def->df_type; + return; } - assert(expp->nd_class == Link && expp->nd_symb == '.'); - assert(expp->nd_left->nd_class == Name); - df = lookfor(expp->nd_left, CurrentScope, 1); - if (df->df_kind == D_ERROR) return df; - nd = expp; - while (nd->nd_class == Link) { - struct node *nd1; - - if (!(scope = has_selectors(df))) { - node_error(nd, "identifier \"%s\" has no selectors", - df->df_idf->id_text); - return ill_df; + if (expp->nd_class == Link) { + assert(expp->nd_symb == '.'); + assert(expp->nd_right->nd_class == Name); + findname(expp->nd_left); + tp = expp->nd_left->nd_type; + if (tp == error_type) { + df = ill_df; } - nd = nd->nd_right; - if (nd->nd_class == Name) nd1 = nd; - else nd1 = nd->nd_left; - module = (df->df_kind == D_MODULE); - df = lookup(nd1->nd_IDF, scope); + else if (tp->tp_fund != RECORD) { + /* This is also true for modules */ + node_error(expp,"Illegal selection"); + df = ill_df; + } + else df = lookup(expp->nd_right->nd_IDF, tp->rec_scope); if (!df) { - id_not_declared(nd1); - return ill_df; + df = ill_df; + id_not_declared(expp->nd_right); } - if (module && !(df->df_flags&(D_EXPORTED|D_QEXPORTED))) { -node_error(nd1, "identifier \"%s\" not exprted from qualifying module", + else if (df != ill_df) { + expp->nd_type = df->df_type; + if (!(df->df_flags & (D_EXPORTED|D_QEXPORTED))) { +node_error(expp->nd_right, +"identifier \"%s\" not exprted from qualifying module", df->df_idf->id_text); + } } + if (expp->nd_left->nd_class == Def) { + expp->nd_class = Def; + expp->nd_def = df; + FreeNode(expp->nd_left); + FreeNode(expp->nd_right); + expp->nd_left = expp->nd_right = 0; + } + return; + } + if (expp->nd_class == Oper) { + assert(expp->nd_symb == '['); + (void) findname(expp->nd_left); + if (chk_expr(expp->nd_right, 0) && + expp->nd_left->nd_type != error_type && + chk_oper(expp)) /* ??? */ ; + return 1; } - return df; + if (expp->nd_class == Uoper && expp->nd_symb == '^') { + (void) findname(expp->nd_right); + if (expp->nd_right->nd_type != error_type && + chk_uoper(expp)) /* ??? */ ; + } + return 0; } int @@ -203,16 +347,14 @@ chk_name(expp, const) register struct def *df; int retval = 1; - df = findname(expp); + (void) findname(expp); + assert(expp->nd_class == Def); + df = expp->nd_def; if (df->df_kind == D_ERROR) { retval = 0; } - expp->nd_type = df->df_type; - if (df->df_kind == D_ENUM || df->df_kind == D_CONST) { - if (expp->nd_left) FreeNode(expp->nd_left); - if (expp->nd_right) FreeNode(expp->nd_right); + if (df->df_kind & (D_ENUM | D_CONST)) { if (df->df_kind == D_ENUM) { - expp->nd_left = expp->nd_right = 0; expp->nd_class = Value; expp->nd_INT = df->enm_val; expp->nd_symb = INTEGER; @@ -251,10 +393,11 @@ chk_oper(expp, const) expp->nd_right->nd_type = tpr = tpl; } } + expp->nd_type = error_type; if (expp->nd_symb == IN) { /* Handle this one specially */ - expp->nd_type == bool_type; + expp->nd_type = bool_type; if (tpr->tp_fund != SET) { node_error(expp, "RHS of IN operator not a SET type"); return 0; @@ -266,6 +409,21 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R return 1; } + if (expp->nd_symb == '[') { + /* Handle ARRAY selection specially too! */ + if (tpl->tp_fund != ARRAY) { +node_error(expp, "array index not belonging to an ARRAY"); + return 0; + } + if (!TstCompat(tpl->next, tpr)) { +node_error(expp, "incompatible index type"); + return 0; + } + expp->nd_type = tpl->arr_elem; + if (const) return 0; + return 1; + } + if (tpl->tp_fund == SUBRANGE) tpl = tpl->next; expp->nd_type = tpl; @@ -450,6 +608,11 @@ chk_uoper(expp, const) return 1; } break; + case '^': + if (tpr->tp_fund != POINTER) break; + expp->nd_type = tpr->next; + if (const) return 0; + return 1; default: assert(0); } diff --git a/lang/m2/comp/const.h b/lang/m2/comp/const.h index 65330a708..41f44cf93 100644 --- a/lang/m2/comp/const.h +++ b/lang/m2/comp/const.h @@ -8,4 +8,5 @@ extern int mach_long_size; /* size of long on this machine == sizeof(long) */ extern arith max_int, /* maximum integer on target machine */ - max_unsigned; /* maximum unsigned on target machine */ + max_unsigned, /* maximum unsigned on target machine */ + wrd_bits; /* Number of bits in a word */ diff --git a/lang/m2/comp/cstoper.c b/lang/m2/comp/cstoper.c index 42948f02d..cb9e14319 100644 --- a/lang/m2/comp/cstoper.c +++ b/lang/m2/comp/cstoper.c @@ -18,6 +18,7 @@ long full_mask[MAXSIZE];/* full_mask[1] == 0xFF, full_mask[2] == 0xFFFF, .. */ arith max_int; /* maximum integer on target machine */ arith max_unsigned; /* maximum unsigned on target machine */ arith max_longint; /* maximum longint on target machine */ +arith wrd_bits; /* number of bits in a word */ cstunary(expp) register struct node *expp; @@ -206,21 +207,85 @@ cstbin(expp) cstset(expp) register struct node *expp; { - switch(expp->nd_symb) { - case IN: - case '+': - case '-': - case '*': - case '/': - case GREATEREQUAL: - case LESSEQUAL: - case '=': - case '#': - /* ??? */ - break; - default: - assert(0); + register arith *set1 = 0, *set2; + register int setsize, j; + + assert(expp->nd_right->nd_class == Set); + assert(expp->nd_symb == IN || expp->nd_left->nd_class == Set); + set2 = expp->nd_right->nd_set; + setsize = expp->nd_right->nd_type->tp_size / wrd_size; + + if (expp->nd_symb == IN) { + arith i; + + assert(expp->nd_left->nd_class == Value); + i = expp->nd_left->nd_INT; + expp->nd_INT = (i >= 0 && + i < setsize * wrd_bits && + (set2[i / wrd_bits] & (1 << (i % wrd_bits)))); + free((char *) set2); + } + else { + set1 = expp->nd_left->nd_set; + switch(expp->nd_symb) { + case '+': + for (j = 0; j < setsize; j++) { + *set1++ |= *set2++; + } + break; + case '-': + for (j = 0; j < setsize; j++) { + *set1++ &= ~*set2++; + } + break; + case '*': + for (j = 0; j < setsize; j++) { + *set1++ &= *set2++; + } + break; + case '/': + for (j = 0; j < setsize; j++) { + *set1++ ^= *set2++; + } + break; + case GREATEREQUAL: + case LESSEQUAL: + case '=': + case '#': + /* Clumsy, but who cares? Nobody writes these things! */ + for (j = 0; j < setsize; j++) { + switch(expp->nd_symb) { + case GREATEREQUAL: + if ((*set1 | *set2++) != *set1) break; + set1++; + continue; + case LESSEQUAL: + if ((*set2 | *set1++) != *set2) break; + set2++; + continue; + case '=': + case '#': + if (*set1++ != *set2++) break; + continue; + } + expp->nd_INT = expp->nd_symb == '#'; + break; + } + if (j == setsize) expp->nd_INT = expp->nd_symb != '#'; + expp->nd_class = Value; + free((char *) expp->nd_left->nd_set); + free((char *) expp->nd_right->nd_set); + break; + default: + assert(0); + } + free((char *) expp->nd_right->nd_set); + expp->nd_class = Set; + expp->nd_set = expp->nd_left->nd_set; } + FreeNode(expp->nd_left); + FreeNode(expp->nd_right); + expp->nd_left = expp->nd_right = 0; } cut_size(expr) @@ -273,4 +338,5 @@ init_cst() max_int = full_mask[int_size] & ~(1 << (int_size * 8 - 1)); max_unsigned = full_mask[int_size]; + wrd_bits = 8 * wrd_size; } diff --git a/lang/m2/comp/declar.g b/lang/m2/comp/declar.g index b2bfe9b40..65dcc05c9 100644 --- a/lang/m2/comp/declar.g +++ b/lang/m2/comp/declar.g @@ -234,7 +234,6 @@ IdentList(struct node **p;) SubrangeType(struct type **ptp;) { struct node *nd1, *nd2; - extern struct type *subr_type(); }: /* This is not exactly the rule in the new report, but see @@ -340,7 +339,6 @@ CaseLabels SetType(struct type **ptp;) { struct type *tp; - struct type *set_type(); } : SET OF SimpleType(&tp) { diff --git a/lang/m2/comp/expression.g b/lang/m2/comp/expression.g index 93bf3ec1c..2abfb97fe 100644 --- a/lang/m2/comp/expression.g +++ b/lang/m2/comp/expression.g @@ -6,6 +6,7 @@ static char *RcsId = "$Header$"; #include #include #include +#include #include "LLlex.h" #include "idf.h" #include "def.h" @@ -36,21 +37,17 @@ qualident(int types; struct def **pdf; char *str; struct node **p;) register struct def *df; register struct node **pnd; struct node *nd; - struct def *findname(); } : IDENT { nd = MkNode(Name, NULLNODE, NULLNODE, &dot); pnd = &nd; } [ - /* selector */ - '.' { *pnd = MkNode(Link,*pnd,NULLNODE,&dot); - pnd = &(*pnd)->nd_right; - } - IDENT - { *pnd = MkNode(Name,NULLNODE,NULLNODE,&dot); } + selector(pnd) ]* { if (types) { - *pdf = df = findname(nd); + findname(nd); + assert(nd->nd_class == Def); + *pdf = df = nd->nd_def; if (df->df_kind != D_ERROR && !(types & df->df_kind)) { error("identifier \"%s\" is not a %s", @@ -62,11 +59,10 @@ qualident(int types; struct def **pdf; char *str; struct node **p;) } ; -/* Inline substituted wherever it occurred -selector: - '.' IDENT +selector(struct node **pnd;): + '.' { *pnd = MkNode(Link,*pnd,NULLNODE,&dot); } + IDENT { (*pnd)->nd_right = MkNode(Name,NULLNODE,NULLNODE,&dot); } ; -*/ ExpList(struct node **pnd;) { @@ -238,11 +234,7 @@ designator(struct node **pnd;) designator_tail(struct node **pnd;): visible_designator_tail(pnd) [ - /* selector */ - '.' { *pnd = MkNode(Link, *pnd, NULLNODE, &dot); } - IDENT { (*pnd)->nd_right = - MkNode(Name, NULLNODE, NULLNODE, &dot); - } + selector(pnd) | visible_designator_tail(pnd) ]* @@ -250,8 +242,15 @@ designator_tail(struct node **pnd;): visible_designator_tail(struct node **pnd;): '[' { *pnd = MkNode(Oper, *pnd, NULLNODE, &dot); } - ExpList(&((*pnd)->nd_right)) + expression(&((*pnd)->nd_right)) + [ + ',' + { *pnd = MkNode(Oper, *pnd, NULLNODE, &dot); + (*pnd)->nd_symb = '['; + } + expression(&((*pnd)->nd_right)) + ]* ']' | - '^' { *pnd = MkNode(Oper, *pnd, NULLNODE, &dot); } + '^' { *pnd = MkNode(Oper, NULLNODE, *pnd, &dot); } ; diff --git a/lang/m2/comp/main.c b/lang/m2/comp/main.c index c20c43f4d..5019dce96 100644 --- a/lang/m2/comp/main.c +++ b/lang/m2/comp/main.c @@ -128,23 +128,23 @@ add_standards() register struct def *df; struct def *Enter(); - (void) Enter("ABS", D_STDFUNC, NULLTYPE, S_ABS); - (void) Enter("CAP", D_STDFUNC, NULLTYPE, S_CAP); - (void) Enter("CHR", D_STDFUNC, NULLTYPE, S_CHR); - (void) Enter("FLOAT", D_STDFUNC, NULLTYPE, S_FLOAT); - (void) Enter("HIGH", D_STDFUNC, NULLTYPE, S_HIGH); - (void) Enter("HALT", D_STDPROC, NULLTYPE, S_HALT); - (void) Enter("EXCL", D_STDPROC, NULLTYPE, S_EXCL); - (void) Enter("DEC", D_STDPROC, NULLTYPE, S_DEC); - (void) Enter("INC", D_STDPROC, NULLTYPE, S_INC); - (void) Enter("VAL", D_STDFUNC, NULLTYPE, S_VAL); - (void) Enter("TRUNC", D_STDFUNC, NULLTYPE, S_TRUNC); - (void) Enter("SIZE", D_STDFUNC, NULLTYPE, S_SIZE); - (void) Enter("ORD", D_STDFUNC, NULLTYPE, S_ORD); - (void) Enter("ODD", D_STDFUNC, NULLTYPE, S_ODD); - (void) Enter("MAX", D_STDFUNC, NULLTYPE, S_MAX); - (void) Enter("MIN", D_STDFUNC, NULLTYPE, S_MIN); - (void) Enter("INCL", D_STDPROC, NULLTYPE, S_INCL); + (void) Enter("ABS", D_PROCEDURE, std_type, S_ABS); + (void) Enter("CAP", D_PROCEDURE, std_type, S_CAP); + (void) Enter("CHR", D_PROCEDURE, std_type, S_CHR); + (void) Enter("FLOAT", D_PROCEDURE, std_type, S_FLOAT); + (void) Enter("HIGH", D_PROCEDURE, std_type, S_HIGH); + (void) Enter("HALT", D_PROCEDURE, std_type, S_HALT); + (void) Enter("EXCL", D_PROCEDURE, std_type, S_EXCL); + (void) Enter("DEC", D_PROCEDURE, std_type, S_DEC); + (void) Enter("INC", D_PROCEDURE, std_type, S_INC); + (void) Enter("VAL", D_PROCEDURE, std_type, S_VAL); + (void) Enter("TRUNC", D_PROCEDURE, std_type, S_TRUNC); + (void) Enter("SIZE", D_PROCEDURE, std_type, S_SIZE); + (void) Enter("ORD", D_PROCEDURE, std_type, S_ORD); + (void) Enter("ODD", D_PROCEDURE, std_type, S_ODD); + (void) Enter("MAX", D_PROCEDURE, std_type, S_MAX); + (void) Enter("MIN", D_PROCEDURE, std_type, S_MIN); + (void) Enter("INCL", D_PROCEDURE, std_type, S_INCL); (void) Enter("CHAR", D_TYPE, char_type, 0); (void) Enter("INTEGER", D_TYPE, int_type, 0); @@ -195,8 +195,8 @@ END SYSTEM.\n"; open_scope(CLOSEDSCOPE, 0); (void) Enter("WORD", D_TYPE, word_type, 0); (void) Enter("ADDRESS", D_TYPE, address_type, 0); - (void) Enter("ADR", D_STDFUNC, NULLTYPE, S_ADR); - (void) Enter("TSIZE", D_STDFUNC, NULLTYPE, S_TSIZE); + (void) Enter("ADR", D_PROCEDURE, std_type, S_ADR); + (void) Enter("TSIZE", D_PROCEDURE, std_type, S_TSIZE); if (!InsertText(SYSTEM, strlen(SYSTEM))) { fatal("Could not insert text"); } diff --git a/lang/m2/comp/node.H b/lang/m2/comp/node.H index 8f0c451e1..eb70a2290 100644 --- a/lang/m2/comp/node.H +++ b/lang/m2/comp/node.H @@ -11,24 +11,16 @@ struct node { #define Oper 2 /* binary operator */ #define Uoper 3 /* unary operator */ #define Call 4 /* cast or procedure - or function call */ -#define Name 5 /* a qualident */ +#define Name 5 /* an identifier */ #define Set 6 /* a set constant */ #define Xset 7 /* a set */ #define Def 8 /* an identified name */ +#define Stat 9 /* a statement */ #define Link 11 struct type *nd_type; /* type of this node */ - union { - struct token ndu_token; /* (Value, Oper, Uoper, Call, Name, - Link) - */ - arith *ndu_set; /* pointer to a set constant (Set) */ - struct def *ndu_def; /* pointer to definition structure for - identified name (Def) - */ - } nd_val; -#define nd_token nd_val.ndu_token -#define nd_set nd_val.ndu_set -#define nd_def nd_val.ndu_def + struct token nd_token; +#define nd_set nd_token.tk_data.tk_set +#define nd_def nd_token.tk_data.tk_def #define nd_symb nd_token.tk_symb #define nd_lineno nd_token.tk_lineno #define nd_filename nd_token.tk_filename diff --git a/lang/m2/comp/program.g b/lang/m2/comp/program.g index 483232cb1..f76742465 100644 --- a/lang/m2/comp/program.g +++ b/lang/m2/comp/program.g @@ -47,6 +47,9 @@ ModuleDeclaration df = define(id, CurrentScope, D_MODULE); open_scope(CLOSEDSCOPE, 0); df->mod_scope = CurrentScope->sc_scope; + df->df_type = + standard_type(RECORD, 0, (arith) 0); + df->df_type->rec_scope = df->mod_scope; } priority? ';' import(1)* @@ -113,6 +116,8 @@ DefinitionModule df = define(id, GlobalScope, D_MODULE); if (!SYSTEMModule) open_scope(CLOSEDSCOPE, 0); df->mod_scope = CurrentScope->sc_scope; + df->df_type = standard_type(RECORD, 0, (arith) 0); + df->df_type->rec_scope = df->mod_scope; DefinitionModule = 1; DO_DEBUG(1, debug("Definition module \"%s\"", id->id_text)); } diff --git a/lang/m2/comp/statement.g b/lang/m2/comp/statement.g index 6f675a269..d9eb42cda 100644 --- a/lang/m2/comp/statement.g +++ b/lang/m2/comp/statement.g @@ -10,7 +10,7 @@ static char *RcsId = "$Header$"; statement { - struct node *nd1, *nd2; + struct node *nd1, *nd2 = 0; } : [ /* @@ -21,8 +21,12 @@ statement designator(&nd1) [ ActualParameters(&nd2)? + { nd1 = MkNode(Call, nd1, nd2, &dot); + nd1->nd_symb = '('; + } | - BECOMES expression(&nd2) + BECOMES { nd1 = MkNode(Stat, nd1, NULLNODE, &dot); } + expression(&(nd1->nd_right)) ] /* * end of changed part diff --git a/lang/m2/comp/type.H b/lang/m2/comp/type.H index c67a8367b..bba1f4afe 100644 --- a/lang/m2/comp/type.H +++ b/lang/m2/comp/type.H @@ -80,6 +80,7 @@ extern struct type *intorcard_type, *string_type, *bitset_type, + *std_type, *error_type; /* All from type.c */ extern int @@ -105,6 +106,8 @@ extern arith struct type *create_type(), *construct_type(), - *standard_type(); /* All from type.c */ + *standard_type(), + *set_type(), + *subr_type(); /* All from type.c */ #define NULLTYPE ((struct type *) 0) diff --git a/lang/m2/comp/type.c b/lang/m2/comp/type.c index 972dede95..36083a1d9 100644 --- a/lang/m2/comp/type.c +++ b/lang/m2/comp/type.c @@ -49,6 +49,7 @@ struct type *intorcard_type, *string_type, *bitset_type, + *std_type, *error_type; struct paramlist *h_paramlist; @@ -132,7 +133,8 @@ init_types() char_type = standard_type(CHAR, 1, (arith) 1); char_type->enm_ncst = 256; - bool_type = standard_type(BOOLEAN, 1, (arith) 1); + bool_type = standard_type(ENUMERATION, 1, (arith) 1); + bool_type->enm_ncst = 2; int_type = standard_type(INTEGER, int_align, int_size); longint_type = standard_type(LONGINT, lint_align, lint_size); card_type = standard_type(CARDINAL, int_align, int_size); @@ -145,8 +147,8 @@ init_types() tp = construct_type(SUBRANGE, int_type); tp->sub_lb = 0; tp->sub_ub = wrd_size * 8 - 1; - bitset_type = construct_type(SET, tp); - bitset_type->tp_size = wrd_size; + bitset_type = set_type(tp); + std_type = construct_type(PROCEDURE, NULLTYPE); error_type = standard_type(ERRONEOUS, 1, (arith) 1); }