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 scope.h target_sizes.h type.h
+type.o: LLlex.h const.h debug.h def.h idf.h maxset.h node.h scope.h target_sizes.h type.h walk.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
defmodule.o: LLlex.h debug.h def.h f_info.h idf.h input.h inputtype.h main.h scope.h
-typequiv.o: LLlex.h def.h node.h type.h
+typequiv.o: LLlex.h debug.h def.h node.h type.h
node.o: LLlex.h debug.h def.h node.h type.h
cstoper.o: LLlex.h Lpars.h debug.h idf.h node.h standards.h target_sizes.h type.h
chk_expr.o: LLlex.h Lpars.h chk_expr.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 chk_expr.h debug.h def.h desig.h f_info.h idf.h main.h node.h scope.h type.h walk.h
-casestat.o: LLlex.h Lpars.h debug.h density.h desig.h node.h type.h
+casestat.o: LLlex.h Lpars.h debug.h density.h desig.h node.h type.h walk.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 standards.h type.h
-tmpvar.o: debug.h def.h scope.h type.h
+code.o: LLlex.h Lpars.h debug.h def.h desig.h node.h scope.h standards.h type.h walk.h
+tmpvar.o: debug.h def.h main.h scope.h type.h
lookup.o: LLlex.h debug.h def.h idf.h node.h scope.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
+declar.o: LLlex.h Lpars.h chk_expr.h debug.h def.h idf.h main.h misc.h node.h scope.h type.h
expression.o: LLlex.h Lpars.h chk_expr.h const.h debug.h def.h idf.h node.h type.h
statement.o: LLlex.h Lpars.h def.h idf.h node.h scope.h type.h
Lpars.o: Lpars.h
#define DEBUG 1 /* perform various self-tests */
extern char options[];
#ifdef DEBUG
-#define DO_DEBUG(n, x) ((n) <= options['D'] && (x))
+#define DO_DEBUG(y, x) ((y) && (x))
#else
-#define DO_DEBUG(n, x)
+#define DO_DEBUG(y, x)
#endif DEBUG
!File: inputtype.h
extern char *symbol2str();
+int
+chk_variable(expp)
+ register struct node *expp;
+{
+
+ if (! chk_designator(expp)) return 0;
+
+ if (expp->nd_class == Def &&
+ !(expp->nd_def->df_kind & (D_FIELD|D_VARIABLE))) {
+ node_error(expp, "variable expected");
+ return 0;
+ }
+
+ return 1;
+}
+
+STATIC int
+chk_arrow(expp)
+ register struct node *expp;
+{
+ register struct type *tp;
+
+ assert(expp->nd_class == Arrow);
+ assert(expp->nd_symb == '^');
+
+ expp->nd_type = error_type;
+
+ if (! chk_variable(expp->nd_right)) return 0;
+
+ tp = expp->nd_right->nd_type;
+
+ if (tp->tp_fund != T_POINTER) {
+ node_error(expp, "illegal operand for unary operator \"%s\"",
+ symbol2str(expp->nd_symb));
+ return 0;
+ }
+
+ expp->nd_type = PointedtoType(tp);
+ return 1;
+}
+
STATIC int
chk_arr(expp)
- struct node *expp;
+ register struct node *expp;
{
- return chk_designator(expp, VARIABLE, D_USED);
+ register struct type *tpl, *tpr;
+
+ assert(expp->nd_class == Arrsel);
+ assert(expp->nd_symb == '[');
+
+ expp->nd_type = error_type;
+
+ if (
+ !chk_variable(expp->nd_left)
+ ||
+ !chk_expr(expp->nd_right)
+ ||
+ expp->nd_left->nd_type == error_type
+ ) return 0;
+
+ tpl = expp->nd_left->nd_type;
+ tpr = expp->nd_right->nd_type;
+
+ if (tpl->tp_fund != T_ARRAY) {
+ node_error(expp, "array index not belonging to an ARRAY");
+ return 0;
+ }
+
+ /* Type of the index must be assignment compatible with
+ the index type of the array (Def 8.1).
+ However, the index type of a conformant array is not specified.
+ Either INTEGER or CARDINAL seems reasonable.
+ */
+ if (IsConformantArray(tpl) ? !TstAssCompat(card_type, tpr)
+ : !TstAssCompat(IndexType(tpl), tpr)) {
+ node_error(expp, "incompatible index type");
+ return 0;
+ }
+
+ expp->nd_type = tpl->arr_elem;
+ return 1;
}
STATIC int
chk_linkorname(expp)
register struct node *expp;
{
- if (chk_designator(expp, VALUE, D_USED)) {
- if (expp->nd_class == Def &&
- expp->nd_def->df_kind == D_PROCEDURE) {
- /* Check that this procedure is one that we
- may take the address from.
- */
- if (expp->nd_def->df_type == std_type ||
- expp->nd_def->df_scope->sc_level > 0) {
- /* Address of standard or nested procedure
- taken.
+ register struct def *df;
+
+ if (expp->nd_class == Name) {
+ expp->nd_def = lookfor(expp, CurrVis, 1);
+ expp->nd_class = Def;
+ expp->nd_type = expp->nd_def->df_type;
+ }
+ else if (expp->nd_class == Link) {
+ register struct node *left = expp->nd_left;
+
+ assert(expp->nd_symb == '.');
+
+ if (! chk_designator(left)) return 0;
+
+ if (left->nd_type->tp_fund != T_RECORD ||
+ (left->nd_class == Def &&
+ !(left->nd_def->df_kind & (D_MODULE|D_VARIABLE|D_FIELD))
+ )
+ ) {
+ node_error(left, "illegal selection");
+ return 0;
+ }
+
+ if (!(df = lookup(expp->nd_IDF, left->nd_type->rec_scope))) {
+ id_not_declared(expp);
+ return 0;
+ }
+ else {
+ expp->nd_def = df;
+ expp->nd_type = df->df_type;
+ expp->nd_class = LinkDef;
+ if (!(df->df_flags & (D_EXPORTED|D_QEXPORTED))) {
+ /* Fields of a record are always D_QEXPORTED,
+ so ...
*/
-node_error(expp, "it is illegal to take the address of a standard or local procedure");
+node_error(expp, "identifier \"%s\" not exported from qualifying module",
+df->df_idf->id_text);
return 0;
}
}
- return 1;
+
+ if (left->nd_class == Def &&
+ left->nd_def->df_kind == D_MODULE) {
+ expp->nd_class = Def;
+ FreeNode(left);
+ expp->nd_left = 0;
+ }
+ else return 1;
}
- return 0;
+
+ assert(expp->nd_class == Def);
+
+ df = expp->nd_def;
+
+ if (df->df_kind & (D_ENUM | D_CONST)) {
+ if (df->df_kind == D_ENUM) {
+ expp->nd_class = Value;
+ expp->nd_INT = df->enm_val;
+ expp->nd_symb = INTEGER;
+ }
+ else {
+ unsigned int ln;
+
+ assert(df->df_kind == D_CONST);
+ ln = expp->nd_lineno;
+ *expp = *(df->con_const);
+ expp->nd_lineno = ln;
+ }
+ }
+
+ return 1;
+}
+
+STATIC int
+chk_ex_linkorname(expp)
+ register struct node *expp;
+{
+ register struct def *df;
+
+ if (! chk_linkorname(expp)) return 0;
+ if (expp->nd_class != Def) return 1;
+ df = expp->nd_def;
+
+ if (!(df->df_kind & (D_ENUM|D_CONST|D_PROCEDURE|D_FIELD|D_VARIABLE|D_PROCHEAD))) {
+ node_error(expp, "value expected");
+ }
+
+ if (df->df_kind == D_PROCEDURE) {
+ /* Check that this procedure is one that we
+ may take the address from.
+ */
+ if (df->df_type == std_type || df->df_scope->sc_level > 0) {
+ /* Address of standard or nested procedure
+ taken.
+ */
+node_error(expp, "it is illegal to take the address of a standard or local procedure");
+ return 0;
+ }
+ }
+
+ return 1;
}
STATIC int
if (nd = expp->nd_left) {
/* A type was given. Check it out
*/
- if (! chk_designator(nd, 0, D_USED)) return 0;
+ if (! chk_designator(nd)) return 0;
assert(nd->nd_class == Def);
df = nd->nd_def;
while (nd) {
assert(nd->nd_class == Link && nd->nd_symb == ',');
- if (!chk_el(nd->nd_left, tp->next, &set)) return 0;
+ if (!chk_el(nd->nd_left, ElementType(tp), &set)) return 0;
nd = nd->nd_right;
}
left = arg->nd_left;
if ((!designator && !chk_expr(left)) ||
- (designator &&
- !chk_designator(left, VARIABLE, D_USED|D_NOREG))) {
+ (designator && !chk_variable(left))) {
return 0;
}
- tp = left->nd_type;
- if (tp->tp_fund == T_SUBRANGE) tp = tp->next;
+ tp = BaseType(left->nd_type);
if (bases && !(tp->tp_fund & bases)) {
node_error(arg, "unexpected type");
}
arg = arg->nd_right;
- if (! chk_designator(arg->nd_left, 0, D_REFERRED)) return 0;
+ if (! chk_designator(arg->nd_left)) return 0;
if (arg->nd_left->nd_class != Def && arg->nd_left->nd_class != LinkDef) {
node_error(arg, "identifier expected");
left = expp->nd_left;
arg = expp;
- expp->nd_type = left->nd_type->next;
+ expp->nd_type = ResultType(left->nd_type);
for (param = ParamList(left->nd_type); param; param = param->next) {
if (!(left = getarg(&arg, 0, IsVarParam(param)))) return 0;
it may also be a cast or a standard procedure call.
*/
register struct node *left;
+ STATIC int chk_std();
+ STATIC int chk_cast();
/* First, get the name of the function or procedure
*/
expp->nd_type = error_type;
left = expp->nd_left;
- if (! chk_designator(left, 0, D_USED)) return 0;
+ if (! chk_designator(left)) return 0;
if (IsCast(left)) {
/* It was a type cast. This is of course not portable.
return 0;
}
-STATIC int
-FlagCheck(expp, df, flag)
- struct node *expp;
- struct def *df;
-{
- /* See the routine "chk_designator" for an explanation of
- "flag". Here, a definition "df" is checked against it.
- */
-
- if (df->df_kind == D_ERROR) return 0;
-
- if ((flag & VARIABLE) &&
- !(df->df_kind & (D_FIELD|D_VARIABLE))) {
- node_error(expp, "variable expected");
- return 0;
- }
-
- if ((flag & HASSELECTORS) &&
- ( !(df->df_kind & (D_VARIABLE|D_FIELD|D_MODULE)) ||
- df->df_type->tp_fund != T_RECORD)) {
- node_error(expp, "illegal selection");
- return 0;
- }
-
- if ((flag & VALUE) &&
- ( !(df->df_kind & (D_VARIABLE|D_FIELD|D_CONST|D_ENUM|D_PROCEDURE)))) {
- node_error(expp, "value expected");
- return 0;
- }
-
- return 1;
-}
-
-int
-chk_designator(expp, flag, dflags)
- register struct node *expp;
-{
- /* Find the name indicated by "expp", starting from the current
- scope. "flag" indicates the kind of designator we expect:
- It contains the flags VARIABLE, indicating that the result must
- be something that can be assigned to.
- It may also contain the flag VALUE, indicating that a
- value is expected. In this case, VARIABLE may not be set.
- 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;
-
- if (expp->nd_class == Def || expp->nd_class == LinkDef) {
- expp->nd_def->df_flags |= dflags;
- return 1;
- }
-
- expp->nd_type = error_type;
-
- if (expp->nd_class == Name) {
- expp->nd_def = lookfor(expp, CurrVis, 1);
- expp->nd_class = Def;
- expp->nd_type = expp->nd_def->df_type;
- }
- else if (expp->nd_class == Link) {
- register struct node *left = expp->nd_left;
-
- assert(expp->nd_symb == '.');
-
- if (! chk_designator(left,
- HASSELECTORS,
- dflags)) return 0;
-
- tp = left->nd_type;
- assert(tp->tp_fund == T_RECORD);
-
- if (!(df = lookup(expp->nd_IDF, tp->rec_scope))) {
- id_not_declared(expp);
- return 0;
- }
- else {
- expp->nd_def = df;
- expp->nd_type = df->df_type;
- expp->nd_class = LinkDef;
- if (!(df->df_flags & (D_EXPORTED|D_QEXPORTED))) {
- /* Fields of a record are always D_QEXPORTED,
- so ...
- */
-node_error(expp, "identifier \"%s\" not exported from qualifying module",
-df->df_idf->id_text);
- return 0;
- }
- }
-
- if (left->nd_class == Def &&
- left->nd_def->df_kind == D_MODULE) {
- expp->nd_class = Def;
- FreeNode(left);
- expp->nd_left = 0;
- }
- else {
- return FlagCheck(expp, df, flag);
- }
- }
-
- if (expp->nd_class == Def) {
- df = expp->nd_def;
-
- if (! FlagCheck(expp, df, flag)) return 0;
-
- if (df->df_kind & (D_ENUM | D_CONST)) {
- if (df->df_kind == D_ENUM) {
- expp->nd_class = Value;
- expp->nd_INT = df->enm_val;
- expp->nd_symb = INTEGER;
- }
- else {
- unsigned int ln;
-
- assert(df->df_kind == D_CONST);
- ln = expp->nd_lineno;
- *expp = *(df->con_const);
- expp->nd_lineno = ln;
- }
- }
-
- df->df_flags |= dflags;
-
- return 1;
- }
-
- if (expp->nd_class == Arrsel) {
- struct type *tpl, *tpr;
-
- assert(expp->nd_symb == '[');
-
- if (
- !chk_designator(expp->nd_left, VARIABLE, dflags)
- ||
- !chk_expr(expp->nd_right)
- ||
- expp->nd_left->nd_type == error_type
- ) return 0;
-
- tpr = expp->nd_right->nd_type;
- tpl = expp->nd_left->nd_type;
-
- if (tpl->tp_fund != T_ARRAY) {
- node_error(expp,
- "array index not belonging to an ARRAY");
- return 0;
- }
-
- /* Type of the index must be assignment compatible with
- the index type of the array (Def 8.1)
- */
- if ((tpl->next && !TstAssCompat(tpl->next, tpr)) ||
- (!tpl->next && !TstAssCompat(intorcard_type, tpr))) {
- node_error(expp, "incompatible index type");
- return 0;
- }
-
- expp->nd_type = tpl->arr_elem;
- return 1;
- }
-
- if (expp->nd_class == Arrow) {
- assert(expp->nd_symb == '^');
-
- if (! chk_designator(expp->nd_right, VARIABLE, dflags)) {
- return 0;
- }
-
- if (expp->nd_right->nd_type->tp_fund != T_POINTER) {
-node_error(expp, "illegal operand for unary operator \"%s\"",
-symbol2str(expp->nd_symb));
- return 0;
- }
-
- expp->nd_type = expp->nd_right->nd_type->next;
- return 1;
- }
-
- node_error(expp, "designator expected");
- return 0;
-}
-
STATIC struct type *
ResultOfOperation(operator, tp)
struct type *tp;
if (!chk_expr(left) || !chk_expr(right)) return 0;
- tpl = left->nd_type;
- tpr = right->nd_type;
-
- if (tpl->tp_fund == T_SUBRANGE) tpl = tpl->next;
- if (tpr->tp_fund == T_SUBRANGE) tpr = tpr->next;
+ tpl = BaseType(left->nd_type);
+ tpr = BaseType(right->nd_type);
if (tpl == intorcard_type) {
if (tpr == int_type || tpr == card_type) {
node_error(expp, "RHS of IN operator not a SET type");
return 0;
}
- if (!TstAssCompat(tpl, tpr->next)) {
+ if (!TstAssCompat(tpl, ElementType(tpr))) {
/* Assignment compatible ???
I don't know! Should we be allowed to check
if a CARDINAL is a member of a BITSET???
if (! chk_expr(right)) return 0;
- tpr = right->nd_type;
- if (tpr->tp_fund == T_SUBRANGE) tpr = tpr->next;
+ tpr = BaseType(right->nd_type);
expp->nd_type = tpr;
switch(expp->nd_symb) {
struct node **argp;
{
register struct node *arg = *argp;
- register struct def *df;
- register struct node *left;
arg = arg->nd_right;
if (!arg) {
return 0;
}
- left = arg->nd_left;
-
- if (! chk_designator(left, 0, D_REFERRED)) return 0;
- if (left->nd_class == Arrsel || left->nd_class == Arrow) {
- *argp = arg;
- return left;
- }
-
- df = 0;
- if (left->nd_class == LinkDef || left->nd_class == Def) {
- df = left->nd_def;
- }
-
- if (!df || !(df->df_kind & (D_VARIABLE|D_FIELD))) {
- node_error(arg, "variable expected");
- return 0;
- }
+ if (! chk_variable(arg->nd_left)) return 0;
*argp = arg;
- return left;
+ return arg->nd_left;
}
-int
+STATIC int
chk_std(expp, left)
register struct node *expp, *left;
{
assert(left->nd_class == Def);
std = left->nd_def->df_value.df_stdname;
-DO_DEBUG(3,debug("standard name \"%s\", %d",left->nd_def->df_idf->id_text,std));
-
switch(std) {
case S_ABS:
if (!(left = getarg(&arg, T_NUMERIC, 0))) return 0;
case S_HIGH:
if (!(left = getarg(&arg, T_ARRAY, 0))) return 0;
- expp->nd_type = left->nd_type->next;
- if (!expp->nd_type) {
- /* A dynamic array has no explicit index type
+ if (IsConformantArray(left->nd_type)) {
+ /* A conformant array has no explicit index type
*/
- expp->nd_type = intorcard_type;
+ expp->nd_type = card_type;
+ }
+ else {
+ expp->nd_type = IndexType(left->nd_type);
+ cstcall(expp, S_MAX);
}
- else cstcall(expp, S_MAX);
break;
case S_MAX:
struct token dt;
struct node *nd;
- dt.TOK_INT = left->nd_type->next->tp_size;
+ dt.TOK_INT = PointedtoType(left->nd_type)->tp_size;
dt.tk_symb = INTEGER;
dt.tk_lineno = left->nd_lineno;
nd = MkLeaf(Value, &dt);
if (!(left = getname(&arg, D_ISTYPE))) return 0;
tp = left->nd_def->df_type;
- if (tp->tp_fund == T_SUBRANGE) tp = tp->next;
if (!(tp->tp_fund & T_DISCRETE)) {
node_error(arg, "unexpected type");
return 0;
return 0;
}
if (!(left = getarg(&arg, T_DISCRETE, 0))) return 0;
- if (!TstAssCompat(tp->next, left->nd_type)) {
+ if (!TstAssCompat(ElementType(tp), left->nd_type)) {
/* What type of compatibility do we want here?
apparently assignment compatibility! ??? ???
*/
return 1;
}
+STATIC int
chk_cast(expp, left)
register struct node *expp, *left;
{
}
}
+STATIC int
+no_desig(expp)
+ struct node *expp;
+{
+ node_error(expp, "designator expected");
+ return 0;
+}
+
+STATIC int
+done_before(expp)
+ struct node *expp;
+{
+ return 1;
+}
+
extern int NodeCrash();
-int (*ChkTable[])() = {
+int (*ExprChkTable[])() = {
chk_value,
chk_arr,
chk_oper,
chk_uoper,
- chk_arr,
+ chk_arrow,
chk_call,
- chk_linkorname,
+ chk_ex_linkorname,
NodeCrash,
chk_set,
NodeCrash,
NodeCrash,
- chk_linkorname,
+ chk_ex_linkorname,
NodeCrash
};
+
+int (*DesigChkTable[])() = {
+ chk_value,
+ chk_arr,
+ no_desig,
+ no_desig,
+ chk_arrow,
+ no_desig,
+ chk_linkorname,
+ NodeCrash,
+ no_desig,
+ done_before,
+ NodeCrash,
+ chk_linkorname,
+ done_before
+};
/* $Header$ */
-extern int (*ChkTable[])(); /* table of expression checking
+extern int (*ExprChkTable[])(); /* table of expression checking
+ functions, indexed by node class
+ */
+extern int (*DesigChkTable[])(); /* table of designator checking
functions, indexed by node class
*/
-#define chk_expr(expp) ((*ChkTable[(expp)->nd_class])(expp))
+#define chk_expr(expp) ((*ExprChkTable[(expp)->nd_class])(expp))
+#define chk_designator(expp) ((*DesigChkTable[(expp)->nd_class])(expp))
{
register int fund1, fund2;
- if (t1->tp_fund == T_SUBRANGE) t1 = t1->next;
- if (t2->tp_fund == T_SUBRANGE) t2 = t2->next;
+ t1 = BaseType(t1);
+ t2 = BaseType(t2);
if (t1 == t2) return;
if ((fund1 = t1->tp_fund) == T_WORD) fund1 = T_INTEGER;
if ((fund2 = t2->tp_fund) == T_WORD) fund2 = T_INTEGER;
C_loc(left->nd_type->tp_size / word_size - 1);
}
else {
- tp = left->nd_type->next;
+ tp = IndexType(left->nd_type);
if (tp->tp_fund == T_SUBRANGE) {
C_loc(tp->sub_ub - tp->sub_lb);
}
if (arg) {
left = arg->nd_left;
- tp = left->nd_type;
- if (tp->tp_fund == T_SUBRANGE) tp = tp->next;
+ tp = BaseType(left->nd_type);
arg = arg->nd_right;
}
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;
+ tp = BaseType(leftop->nd_type); /* Not the result type! */
switch (tp->tp_fund) {
case T_INTEGER:
C_cmi(tp->tp_size);
register struct node *nd;
register struct type *tp;
{
+ register struct type *eltype = ElementType(tp);
if (nd->nd_class == Link && nd->nd_symb == UPTO) {
C_loc(tp->tp_size); /* push size */
- if (tp->next->tp_fund == T_SUBRANGE) {
- C_loc(tp->next->sub_ub);
+ if (eltype->tp_fund == T_SUBRANGE) {
+ C_loc(eltype->sub_ub);
}
- else C_loc((arith) (tp->next->enm_ncst - 1));
+ else C_loc((arith) (eltype->enm_ncst - 1));
Operands(nd->nd_left, nd->nd_right);
C_cal("_LtoUset"); /* library routine to fill set */
C_asp(4 * word_size);
conform to the size of the type of the expression.
*/
arith o1 = expr->nd_INT;
- struct type *tp = expr->nd_type;
+ struct type *tp = BaseType(expr->nd_type);
int uns;
int size = tp->tp_size;
assert(expr->nd_class == Value);
- if (tp->tp_fund == T_SUBRANGE) tp = tp->next;
uns = (tp->tp_fund & (T_CARDINAL|T_CHAR));
if (uns) {
if (o1 & ~full_mask[size]) {
#include "node.h"
#include "misc.h"
#include "main.h"
+#include "chk_expr.h"
int proclevel = 0; /* nesting level of procedures */
int return_occurred; /* set if a return occurred in a
ProcedureHeading(struct def **pdf; int type;)
{
- struct type *tp = 0;
struct paramlist *params = 0;
+ struct type *tp = 0;
register struct def *df;
struct def *DeclProc();
+ arith NBytesParams;
} :
PROCEDURE IDENT
{
df = DeclProc(type);
- tp = construct_type(T_PROCEDURE, tp);
if (proclevel > 1) {
/* Room for static link
*/
- tp->prc_nbpar = pointer_size;
+ NBytesParams = pointer_size;
}
- else tp->prc_nbpar = 0;
+ else NBytesParams = 0;
}
- FormalParameters(¶ms, &(tp->next), &(tp->prc_nbpar))?
+ FormalParameters(¶ms, &tp, &NBytesParams)?
{
+ tp = construct_type(T_PROCEDURE, tp);
tp->prc_params = params;
+ tp->prc_nbpar = NBytesParams;
if (df->df_type) {
/* We already saw a definition of this type
in the definition module.
if (type == D_PROCHEAD) close_scope(0);
- DO_DEBUG(1, type == D_PROCEDURE &&
- (print("proc %s:", df->df_idf->id_text),
- DumpType(tp), print("\n")));
}
;
-block(struct node **pnd;)
-{
-}:
+block(struct node **pnd;) :
declaration*
[
BEGIN
]*
]?
')'
- { *tp = 0; }
[ ':' qualident(D_ISTYPE, &df, "type", (struct node **) 0)
{ *tp = df->df_type;
}
struct node *FPList;
struct type *tp;
int VARp = D_VALPAR;
+ struct paramlist *p = 0;
} :
[
VAR { VARp = D_VARPAR; }
]?
- IdentList(&FPList) ':' FormalType(&tp)
- { EnterParamList(ppr, FPList, tp, VARp, parmaddr); }
+ IdentList(&FPList) ':' FormalType(&p, 0)
+ { EnterParamList(ppr, FPList, p->par_def->df_type,
+ VARp, parmaddr);
+ free_def(p->par_def);
+ free_paramlist(p);
+ }
;
-FormalType(struct type **ptp;)
+FormalType(struct paramlist **ppr; int VARp;)
{
- struct def *df;
- int ARRAYflag = 0;
+ struct def *df1;
+ register struct def *df;
+ int ARRAYflag;
register struct type *tp;
+ register struct paramlist *p = new_paramlist();
extern arith ArrayElSize();
} :
[ ARRAY OF { ARRAYflag = 1; }
- ]?
- qualident(D_ISTYPE, &df, "type", (struct node **) 0)
- { if (ARRAYflag) {
- *ptp = tp = construct_type(T_ARRAY, NULLTYPE);
+ | { ARRAYflag = 0; }
+ ]
+ qualident(D_ISTYPE, &df1, "type", (struct node **) 0)
+ { df = df1;
+ if (ARRAYflag) {
+ tp = construct_type(T_ARRAY, NULLTYPE);
tp->arr_elem = df->df_type;
tp->arr_elsize = ArrayElSize(df->df_type);
tp->tp_align = lcm(word_align, pointer_align);
}
- else *ptp = df->df_type;
+ else tp = df->df_type;
+ p->next = *ppr;
+ *ppr = p;
+ p->par_def = df = new_def();
+ df->df_type = tp;
+ df->df_flags = VARp;
}
;
{ warning("Old fashioned Modula-2 syntax!");
id = gen_anon_idf();
df = ill_df;
- if (chk_designator(nd, 0, D_REFERRED) &&
+ if (chk_designator(nd) &&
(nd->nd_class != Def ||
!(nd->nd_def->df_kind &
(D_ERROR|D_ISTYPE)))) {
FormalTypeList(struct paramlist **ppr; struct type **ptp;)
{
struct def *df;
- struct type *tp;
- struct paramlist *p;
int VARp;
} :
'(' { *ppr = 0; }
[ VAR { VARp = D_VARPAR; }
| { VARp = D_VALPAR; }
]
- FormalType(&tp)
- { *ppr = p = new_paramlist();
- p->next = 0;
- p->par_def = df = new_def();
- df->df_type = tp;
- df->df_flags = VARp;
- }
+ FormalType(ppr, VARp)
[
','
[ VAR {VARp = D_VARPAR; }
| {VARp = D_VALPAR; }
]
- FormalType(&tp)
- { p = new_paramlist();
- p->next = *ppr; *ppr = p;
- p->par_def = df = new_def();
- df->df_type = tp;
- df->df_flags = VARp;
- }
+ FormalType(ppr, VARp)
]*
]?
')'
fatal("Could'nt find a DEFINITION MODULE for \"%s\"", name);
}
LineNumber = 1;
- DO_DEBUG(1, debug("File %s : %ld characters", FileName, sys_filesize(FileName)));
+ DO_DEBUG(options['F'], debug("File %s : %ld characters", FileName, sys_filesize(FileName)));
}
struct def *
{ if (types) {
df = ill_df;
- if (chk_designator(nd, 0, D_REFERRED)) {
+ if (chk_designator(nd)) {
if (nd->nd_class != Def) {
node_error(nd, "%s expected", str);
}
* Changed rule in new Modula-2.
* Check that the expression is a constant expression and evaluate!
*/
- { DO_DEBUG(3,
- ( debug("Constant expression:"),
- PrNode(*pnd)));
+ { DO_DEBUG(options['X'], print("CONSTANT EXPRESSION\n"));
+ DO_DEBUG(options['X'], PrNode(*pnd, 0));
if (chk_expr(*pnd) &&
((*pnd)->nd_class != Set && (*pnd)->nd_class != Value)) {
error("Constant expression expected");
}
- DO_DEBUG(3, PrNode(*pnd));
+ DO_DEBUG(options['X'], print("RESULTS IN\n"));
+ DO_DEBUG(options['X'], PrNode(*pnd, 0));
}
;
fprint(STDERR, "%s: Use a file argument\n", ProgName);
return 1;
}
-#ifdef DEBUG
- DO_DEBUG(1, debug("Debugging level: %d", options['D']));
-#endif DEBUG
return !Compile(Nargv[1], Nargv[2]);
}
{
extern struct tokenname tkidf[];
- DO_DEBUG(1, debug("Filename : %s", src));
- DO_DEBUG(1, (!dst || debug("Targetfile: %s", dst)));
if (! InsertFile(src, (char **) 0, &src)) {
fprint(STDERR,"%s: cannot open %s\n", ProgName, src);
return 0;
C_ms_src((arith) (LineNumber - 1), FileName);
close_scope(SC_REVERSE);
if (!err_occurred) {
+ C_exp(Defined->mod_vis->sc_scope->sc_name);
WalkModule(Defined);
if (fp_used) {
C_ms_flt();
nd->nd_token = *token;
nd->nd_class = class;
nd->nd_type = error_type;
- DO_DEBUG(4,(debug("Create node:"), PrNode(nd)));
return nd;
}
extern char *symbol2str();
-STATIC
-printnode(nd)
- register struct node *nd;
+indnt(lvl)
{
- fprint(STDERR, "(");
- if (nd) {
- printnode(nd->nd_left);
- fprint(STDERR, " %s ", symbol2str(nd->nd_symb));
- printnode(nd->nd_right);
+ while (lvl--) {
+ print(" ");
}
- fprint(STDERR, ")");
}
-PrNode(nd)
- struct node *nd;
+printnode(nd, lvl)
+ register struct node *nd;
{
- printnode(nd);
- fprint(STDERR, "\n");
+ indnt(lvl);
+ print("C: %d; T: %s\n", nd->nd_class, symbol2str(nd->nd_symb));
+}
+
+PrNode(nd, lvl)
+ register struct node *nd;
+{
+ if (! nd) {
+ indnt(lvl); print("<nilnode>\n");
+ return;
+ }
+ PrNode(nd->nd_left, lvl + 1);
+ printnode(nd, lvl);
+ PrNode(nd->nd_right, lvl + 1);
}
#endif DEBUG
df->df_type = standard_type(T_RECORD, 0, (arith) 0);
df->df_type->rec_scope = df->mod_vis->sc_scope;
DefinitionModule++;
- DO_DEBUG(1, debug("Definition module \"%s\" %d",
- id->id_text, DefinitionModule));
}
';'
import(0)*
df = define(id, CurrentScope, D_MODULE);
open_scope(CLOSEDSCOPE);
df->mod_vis = CurrVis;
- CurrentScope->sc_name = id->id_text;
+ CurrentScope->sc_name = "_M2M";
}
Defined = df;
CurrentScope->sc_definedby = df;
if (flag) {
if (sc->sc_forw) rem_forwards(sc->sc_forw);
- DO_DEBUG(2, PrScopeDef(sc->sc_def));
+ DO_DEBUG(options['S'], PrScopeDef(sc->sc_def));
if (flag & SC_CHKPROC) chk_proc(sc->sc_def);
if (flag & SC_CHKFORW) chk_forw(&(sc->sc_def));
if (flag & SC_REVERSE) Reverse(&(sc->sc_def));
static char *RcsId = "$Header$";
#endif
+#include <assert.h>
#include <em_arith.h>
#include <em_label.h>
{ if (scopeclosed(CurrentScope)) {
error("a module body has no result value");
}
- else if (! df->df_type->next) {
+ else if (! ResultType(df->df_type)) {
error("procedure \"%s\" has no result value", df->df_idf->id_text);
}
}
|
- { if (df->df_type->next) {
+ { if (ResultType(df->df_type)) {
error("procedure \"%s\" must return a value", df->df_idf->id_text);
}
}
#include "def.h"
#include "type.h"
#include "scope.h"
+#include "main.h"
struct tmpvar {
struct tmpvar *next;
if (!TmpInts) {
offset = - WA(align(int_size - ProcScope->sc_off, int_align));
ProcScope->sc_off = offset;
- C_ms_reg(offset, int_size, reg_any, 0);
+ if (! options['n']) C_ms_reg(offset, int_size, reg_any, 0);
}
else {
tmp = TmpInts;
if (!TmpPtrs) {
offset = - WA(align(pointer_size - ProcScope->sc_off, pointer_align));
ProcScope->sc_off = offset;
- C_ms_reg(offset, pointer_size, reg_pointer, 0);
+ if (! options['n']) C_ms_reg(offset, pointer_size, reg_pointer, 0);
}
else {
tmp = TmpPtrs;
#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 WA(sz) (align(sz, (int) word_size))
-#define ResultType(tpx) (assert((tpx)->tp_fund == T_PROCEDURE), (tpx)->next)
-#define ParamList(tpx) (assert((tpx)->tp_fund == T_PROCEDURE),\
+#define bounded(tpx) ((tpx)->tp_fund & T_INDEX)
+#define complex(tpx) ((tpx)->tp_fund & (T_RECORD|T_ARRAY))
+#define WA(sz) (align(sz, (int) word_size))
+#define ResultType(tpx) (assert((tpx)->tp_fund == T_PROCEDURE),\
+ (tpx)->next)
+#define ParamList(tpx) (assert((tpx)->tp_fund == T_PROCEDURE),\
(tpx)->prc_params)
+#define IndexType(tpx) (assert((tpx)->tp_fund == T_ARRAY),\
+ (tpx)->next)
+#define ElementType(tpx) (assert((tpx)->tp_fund == T_SET),\
+ (tpx)->next)
+#define PointedtoType(tpx) (assert((tpx)->tp_fund == T_POINTER),\
+ (tpx)->next)
+#define BaseType(tpx) ((tpx)->tp_fund == T_SUBRANGE ? (tpx)->next\
+ : (tpx))
#define IsConstructed(tpx) ((tpx)->tp_fund & T_CONSTRUCTED)
if (base->sub_lb > tp->sub_lb || base->sub_ub < tp->sub_ub) {
error("Base type has insufficient range");
}
- base = base->next;
+ base = BaseType(base);
}
if (base->tp_fund & (T_ENUMERATION|T_CHAR)) {
- if (tp->next != base) {
+ if (BaseType(tp) != base) {
error("Specified base does not conform");
}
}
else if (base != card_type && base != int_type) {
error("Illegal base for a subrange");
}
- else if (base == int_type && tp->next == card_type &&
+ else if (base == int_type && BaseType(tp) == card_type &&
(tp->sub_ub > max_int || tp->sub_ub < 0)) {
error("Upperbound to large for type INTEGER");
}
- else if (base != tp->next && base != int_type) {
+ else if (base != BaseType(tp) && base != int_type) {
error("Specified base does not conform");
}
indicated by "lb" and "ub", but first perform some
checks
*/
- register struct type *tp = lb->nd_type, *res;
+ register struct type *tp = BaseType(lb->nd_type), *res;
if (!TstCompat(lb->nd_type, ub->nd_type)) {
node_error(ub, "Types of subrange bounds not equal");
return error_type;
}
- if (tp->tp_fund == T_SUBRANGE) tp = tp->next;
-
if (tp == intorcard_type) {
/* Lower bound >= 0; in this case, the base type is CARDINAL,
according to the language definition, par. 6.3
{
/* Assign sizes to an array type, and check index type
*/
- register struct type *index_type = tp->next;
+ register struct type *index_type = IndexType(tp);
register struct type *elem_type = tp->arr_elem;
arith lo, hi;
/* First check if the result types are equivalent
*/
- if (! TstTypeEquiv(tp1->next, tp2->next)) return 0;
+ if (! TstTypeEquiv(ResultType(tp1), ResultType(tp2))) return 0;
p1 = ParamList(tp1);
p2 = ParamList(tp2);
if (TstTypeEquiv(tp1, tp2)) return 1;
- if (tp1->tp_fund == T_SUBRANGE) tp1 = tp1->next;
- if (tp2->tp_fund == T_SUBRANGE) tp2 = tp2->next;
+ tp1 = BaseType(tp1);
+ tp2 = BaseType(tp2);
return tp1 == tp2
||
if (TstCompat(tp1, tp2)) return 1;
- if (tp1->tp_fund == T_SUBRANGE) tp1 = tp1->next;
- if (tp2->tp_fund == T_SUBRANGE) tp2 = tp2->next;
+ tp1 = BaseType(tp1);
+ tp2 = BaseType(tp2);
if ((tp1->tp_fund & T_INTORCARD) &&
(tp2->tp_fund & T_INTORCARD)) return 1;
*/
arith size;
- if (!(tp = tp1->next)) return 0;
+ if (IsConformantArray(tp1)) return 0;
+ tp = IndexType(tp1);
if (tp->tp_fund == T_SUBRANGE) {
size = tp->sub_ub - tp->sub_lb + 1;
}
else size = tp->enm_ncst;
- tp1 = tp1->arr_elem;
- if (tp1->tp_fund == T_SUBRANGE) tp1 = tp1->next;
+ tp1 = BaseType(tp1->arr_elem);
return
tp1 == char_type
&& (tp2->tp_fund == T_STRING && size >= tp2->tp_size)
Also generate code for its body.
*/
register struct scope *sc;
- struct scopelist *vis;
+ struct scopelist *savevis = CurrVis;
- vis = CurrVis;
CurrVis = module->mod_vis;
sc = CurrentScope;
- if (!proclevel && module == Defined) {
- /* This module is a global module. Export the name of its
- initialization routine
- */
- if (state == PROGRAM) C_exp("main");
- else C_exp(sc->sc_name);
- }
-
- /* Now, walk through it's local definitions
+ /* Walk through it's local definitions
*/
WalkDef(sc->sc_def);
*/
sc->sc_off = 0;
text_label = 1;
- ProcScope = CurrentScope;
- C_pro_narg(state==PROGRAM && module==Defined ? "main" : sc->sc_name);
+ ProcScope = sc;
+ C_pro_narg(sc->sc_name);
DoProfil();
if (module == Defined) {
/* Body of implementation or program module.
Call initialization routines of imported modules.
Also prevent recursive calls of this one.
*/
- struct node *nd;
+ register struct node *nd;
if (state == IMPLEMENTATION) {
label l1 = ++data_label;
C_ste_dlb(l1, (arith) 0);
}
- nd = Modules;
- while (nd) {
+ for (nd = Modules; nd; nd = nd->next) {
C_cal(nd->nd_IDF->id_text);
- nd = nd->next;
}
}
MkCalls(sc->sc_def);
proclevel++;
+ DO_DEBUG(options['X'], PrNode(module->mod_body, 0));
WalkNode(module->mod_body, (label) 0);
C_df_ilb((label) 1);
C_ret((arith) 0);
proclevel--;
TmpClose();
- CurrVis = vis;
+ CurrVis = savevis;
}
WalkProcedure(procedure)
register struct def *procedure;
{
/* Walk through the definition of a procedure and all its
- local definitions
+ local definitions, checking and generating code.
*/
struct scopelist *savevis = CurrVis;
register struct scope *sc;
proclevel++;
CurrVis = procedure->prc_vis;
ProcScope = sc = CurrentScope;
-
+
/* Generate code for all local modules and procedures
*/
WalkDef(sc->sc_def);
C_bss_cst(tp->tp_size, (arith) 0, 0);
}
+ DO_DEBUG(options['X'], PrNode(procedure->prc_body, 0));
WalkNode(procedure->prc_body, (label) 0);
C_ret((arith) 0);
if (tp) {
else C_ret(WA(tp->tp_size));
}
- RegisterMessages(sc->sc_def);
+ if (! options['n']) RegisterMessages(sc->sc_def);
C_end(-sc->sc_off);
TmpClose();
CurrVis = savevis;
}
C_bra(l1);
C_df_ilb(l2);
+ CheckAssign(nd->nd_type, int_type);
+ CodeDStore(nd);
WalkNode(right, lab);
- C_loc(left->nd_INT);
CodePExpr(nd);
+ C_loc(left->nd_INT);
C_adi(int_size);
- CodeDStore(nd);
C_df_ilb(l1);
- CodePExpr(nd);
+ C_dup(int_size);
if (tmp) C_lol(tmp); else C_loc(fnd->nd_INT);
if (left->nd_INT > 0) {
C_ble(l2);
}
else C_bge(l2);
+ C_asp(int_size);
if (tmp) FreeInt(tmp);
}
break;
/* Check an expression and generate code for it
*/
- DO_DEBUG(1, (DumpTree(nd), print("\n")));
-
if (! chk_expr(nd)) return;
CodePExpr(nd);
/* Check designator and generate code for it
*/
- DO_DEBUG(1, (DumpTree(nd), print("\n")));
-
- if (! chk_designator(nd, VARIABLE, D_DEFINED)) return;
+ if (! chk_variable(nd)) return;
*ds = InitDesig;
CodeDesig(nd, ds);
nd->nd_class = Name;
nd->nd_symb = IDENT;
- if (! chk_designator(nd, VARIABLE, D_DEFINED) ||
+ if (! chk_variable(nd) ||
! chk_expr(left->nd_left) ||
! chk_expr(left->nd_right)) return 0;
}
CodePExpr(left->nd_left);
- CodeDStore(nd);
return 1;
}
struct desig dsl, dsr;
if (!chk_expr(right)) return;
- if (! chk_designator(left, VARIABLE, D_DEFINED)) return;
+ if (! chk_variable(left)) return;
TryToString(right, left->nd_type);
dsr = InitDesig;
CodeExpr(right, &dsr, NO_LABEL, NO_LABEL);
RegisterMessages(df)
register struct def *df;
{
- struct type *tp;
+ register struct type *tp;
for (; df; df = df->df_nextinscope) {
if (df->df_kind == D_VARIABLE && !(df->df_flags & D_NOREG)) {
/* Examine type and size
*/
- tp = df->df_type;
- if (tp->tp_fund == T_SUBRANGE) tp = tp->next;
- if ((tp->tp_fund & T_NUMERIC) &&
+ tp = BaseType(df->df_type);
+ if ((df->df_flags & D_VARPAR) ||
+ tp->tp_fund == T_POINTER) {
+ C_ms_reg(df->var_off, pointer_size,
+ reg_pointer, 0);
+ }
+ else if ((tp->tp_fund & T_NUMERIC) &&
tp->tp_size <= dword_size) {
C_ms_reg(df->var_off,
tp->tp_size,
reg_float : reg_any,
0);
}
- else if ((df->df_flags & D_VARPAR) ||
- tp->tp_fund == T_POINTER) {
- C_ms_reg(df->var_off, pointer_size,
- reg_pointer, 0);
- }
}
}
}
-
-#ifdef DEBUG
-DumpTree(nd)
- struct node *nd;
-{
- char *s;
- extern char *symbol2str();
-
- if (!nd) {
- print("()");
- return;
- }
-
- print("(");
- DumpTree(nd->nd_left);
- switch(nd->nd_class) {
- case Def: s = "Def"; break;
- case Oper: s = "Oper"; break;
- case Arrsel: s = "Arrsel"; break;
- case Arrow: s = "Arrow"; break;
- case Uoper: s = "Uoper"; break;
- case Name: s = "Name"; break;
- case Set: s = "Set"; break;
- case Value: s = "Value"; break;
- case Call: s = "Call"; break;
- case Xset: s = "Xset"; break;
- case Stat: s = "Stat"; break;
- case Link: s = "Link"; break;
- default: s = "ERROR"; break;
- }
- print("%s %s", s, symbol2str(nd->nd_symb));
- DumpTree(nd->nd_right);
- print(")");
-}
-#endif
public / ack.git / commitdiff