diff --git a/lang/m2/comp/LLlex.c b/lang/m2/comp/LLlex.c index 15fd0f383..14506180d 100644 --- a/lang/m2/comp/LLlex.c +++ b/lang/m2/comp/LLlex.c @@ -529,12 +529,30 @@ lexwarning(W_ORDINARY, "character constant out of range"); return tk->tk_symb = INTEGER; } if (ch == 'D' && base == 10) { + if (options['l']) { + /* Local extension: LONGCARD exists, + so internally also longintorcard_type + exists. + */ + toktype = longcard_type; + if (ovfl == 0 && tk->TOK_INT >= 0 && + tk->TOK_INT<=max_int[(int)long_size]) { + toktype = longintorcard_type; + } + else if (! chk_bounds(tk->TOK_INT, + full_mask[(int)long_size], + T_CARDINAL)) { + ovfl = 1; + } + } + else { if (ovfl != 0 || tk->TOK_INT > max_int[(int)long_size] || tk->TOK_INT < 0) { ovfl = 1; } toktype = longint_type; + } } else if (ovfl == 0 && tk->TOK_INT >= 0 && tk->TOK_INT<=max_int[(int)int_size]) { @@ -543,7 +561,7 @@ lexwarning(W_ORDINARY, "character constant out of range"); else if (! chk_bounds(tk->TOK_INT, full_mask[(int)int_size], T_CARDINAL)) { - ovfl = 1; + ovfl = 1; } if (ovfl) lexwarning(W_ORDINARY, "overflow in constant"); diff --git a/lang/m2/comp/chk_expr.c b/lang/m2/comp/chk_expr.c index 0dd7f11fc..25f0f2d5c 100644 --- a/lang/m2/comp/chk_expr.c +++ b/lang/m2/comp/chk_expr.c @@ -921,10 +921,10 @@ ChkBinOper(expp) tpr = BaseType(exp->nd_RIGHT->nd_type); if (intorcard(tpl, tpr) != 0) { - if (tpl == intorcard_type) { + if (tpl->tp_fund == T_INTORCARD) { exp->nd_LEFT->nd_type = tpl = tpr; } - if (tpr == intorcard_type) { + if (tpr->tp_fund == T_INTORCARD) { exp->nd_RIGHT->nd_type = tpr = tpl; } } @@ -1052,6 +1052,9 @@ ChkUnOper(expp) if (tpr == intorcard_type) { exp->nd_type = int_type; } + else if (tpr == longintorcard_type) { + exp->nd_type = longint_type; + } if (right->nd_class == Value) { cstunary(expp); } @@ -1166,7 +1169,7 @@ ChkStandard(expp) case S_SHORT: case S_LONG: { t_type *tp; - t_type *s1, *s2, *d1, *d2; + t_type *s1, *s2, *s3, *d1, *d2, *d3; if (!(arg = getarg(&arglink, 0, 0, edf))) { return 0; @@ -1178,12 +1181,16 @@ ChkStandard(expp) d1 = int_type; s2 = longreal_type; d2 = real_type; + s3 = longcard_type; + d3 = card_type; } else { d1 = longint_type; s1 = int_type; d2 = longreal_type; s2 = real_type; + d3 = longcard_type; + s3 = card_type; } if (tp == s1) { @@ -1192,6 +1199,9 @@ ChkStandard(expp) else if (tp == s2) { MkCoercion(&(arglink->nd_LEFT), d2); } + else if (options['l'] && tp == s3) { + MkCoercion(&(arglink->nd_LEFT), d3); + } else { df_error(arg, "unexpected parameter type", edf); break; @@ -1330,7 +1340,8 @@ ChkStandard(expp) if (! getarg(&arglink, T_REAL, 0, edf)) return 0; MkCoercion(&(arglink->nd_LEFT), edf->df_value.df_stdname == S_TRUNCD ? - longint_type : card_type); + options['l'] ? longcard_type : longint_type + : card_type); free_it = 1; break; diff --git a/lang/m2/comp/code.c b/lang/m2/comp/code.c index 2bc8f75c5..4916f127e 100644 --- a/lang/m2/comp/code.c +++ b/lang/m2/comp/code.c @@ -687,8 +687,8 @@ RangeCheck(tpl, tpr) return; } tpr = BaseType(tpr); - if ((tpl->tp_fund == T_INTEGER && tpr == card_type) || - (tpr->tp_fund == T_INTEGER && tpl == card_type)) { + if ((tpl->tp_fund == T_INTEGER && tpr->tp_fund == T_CARDINAL) || + (tpr->tp_fund == T_INTEGER && tpl->tp_fund == T_CARDINAL)) { label lb = ++text_label; C_dup(tpr->tp_size); @@ -865,7 +865,7 @@ CodeOper(expr, true_label, false_label) Operands(expr); tp = BaseType(leftop->nd_type); - if (tp == intorcard_type) tp = BaseType(rightop->nd_type); + if (tp->tp_fund == T_INTORCARD) tp = BaseType(rightop->nd_type); size = tp->tp_size; switch (tp->tp_fund) { case T_INTEGER: diff --git a/lang/m2/comp/cstoper.c b/lang/m2/comp/cstoper.c index 2ee060b4c..fafb560f2 100644 --- a/lang/m2/comp/cstoper.c +++ b/lang/m2/comp/cstoper.c @@ -615,8 +615,8 @@ cstcall(expp, call) if (tp->tp_fund == T_INTEGER) { expr->nd_INT = max_int[(int)(tp->tp_size)]; } - else if (tp == card_type) { - expr->nd_INT = full_mask[(int)(int_size)]; + else if (tp->tp_fund == T_CARDINAL) { + expr->nd_INT = full_mask[(int)(tp->tp_size)]; } else if (tp->tp_fund == T_SUBRANGE) { expr->nd_INT = tp->sub_ub; diff --git a/lang/m2/comp/em_m2.6 b/lang/m2/comp/em_m2.6 index 29e2eeb53..a122a4a30 100644 --- a/lang/m2/comp/em_m2.6 +++ b/lang/m2/comp/em_m2.6 @@ -65,8 +65,8 @@ make all procedure names global, so that \fIadb\fR(1) understands them. .IP \fB\-g\fR produce a DBX-style symbol table. .IP \fB\-l\fR -enable local extensions. Currently, the only local extension consists of -procedure constants. +enable local extensions. Currently, there are two local extensions: +procedure constants, and the type LONGCARD. .IP \fB\-s\fR make INTEGER ranges symmetric, t.i., MIN(INTEGER) = - MAX(INTEGER). This is useful for interpreters that use the "real" MIN(INTEGER) to diff --git a/lang/m2/comp/main.c b/lang/m2/comp/main.c index 47aa5354c..4b181eb83 100644 --- a/lang/m2/comp/main.c +++ b/lang/m2/comp/main.c @@ -221,6 +221,10 @@ AddStandards() EnterType("REAL", real_type); EnterType("LONGREAL", longreal_type); EnterType("CARDINAL", card_type); + if (options['l']) { + /* local extension: LONGCARD. */ + EnterType("LONGCARD", longcard_type); + } EnterType("(void)", void_type); df = Enter("NIL", D_CONST, address_type, 0); df->con_const = nilconst; diff --git a/lang/m2/comp/type.H b/lang/m2/comp/type.H index c05137440..b677fa516 100644 --- a/lang/m2/comp/type.H +++ b/lang/m2/comp/type.H @@ -136,6 +136,7 @@ extern t_type *byte_type, *address_type, *intorcard_type, + *longintorcard_type, *bitset_type, *void_type, *std_type, diff --git a/lang/m2/comp/type.c b/lang/m2/comp/type.c index 38a7e904b..fa0283d73 100644 --- a/lang/m2/comp/type.c +++ b/lang/m2/comp/type.c @@ -70,6 +70,7 @@ t_type *byte_type, *address_type, *intorcard_type, + *longintorcard_type, *bitset_type, *void_type, *std_type, @@ -187,6 +188,7 @@ InitTypes() longcard_type = standard_type(T_CARDINAL, long_align, long_size); card_type = standard_type(T_CARDINAL, int_align, int_size); intorcard_type = standard_type(T_INTORCARD, int_align, int_size); + longintorcard_type = standard_type(T_INTORCARD, long_align, long_size); /* floating types */ @@ -844,13 +846,13 @@ t_type * intorcard(left, right) register t_type *left, *right; { - if (left == intorcard_type) { + if (left->tp_fund == T_INTORCARD) { t_type *tmp = left; left = right; right = tmp; } - if (right == intorcard_type) { - if (left == int_type || left == card_type) { + if (right->tp_fund == T_INTORCARD) { + if (left->tp_fund == T_INTEGER || left->tp_fund == T_CARDINAL) { return left; } } diff --git a/lang/m2/comp/typequiv.c b/lang/m2/comp/typequiv.c index 1cec5ee22..2a3efbb7c 100644 --- a/lang/m2/comp/typequiv.c +++ b/lang/m2/comp/typequiv.c @@ -111,8 +111,8 @@ TstCompat(tp1, tp2) tp1 = BaseType(tp1); tp2 = BaseType(tp2); - if (tp2 != intorcard_type && - (tp1 == intorcard_type || tp1 == address_type)) { + if (tp2->tp_fund != T_INTORCARD && + (tp1->tp_fund == T_INTORCARD || tp1 == address_type)) { t_type *tmp = tp2; tp2 = tp1; @@ -125,10 +125,15 @@ TstCompat(tp1, tp2) && (tp1 == int_type || tp1 == card_type || tp1 == address_type) ) + || + ( tp2 == longintorcard_type + && + (tp1 == longint_type || tp1 == longcard_type || tp1 == address_type) + ) || ( tp2 == address_type && - ( tp1 == card_type || tp1->tp_fund == T_POINTER) + ( tp1->tp_fund == T_CARDINAL || tp1->tp_fund == T_POINTER) ) ; }