diff --git a/lang/m2/comp/chk_expr.c b/lang/m2/comp/chk_expr.c index 696cadc2a..6c70cb11c 100644 --- a/lang/m2/comp/chk_expr.c +++ b/lang/m2/comp/chk_expr.c @@ -324,6 +324,10 @@ ChkExLinkOrName(expp) expp->nd_class = Set; inc_refcount(expp->nd_set); } + else if (df->df_type->tp_fund == T_PROCEDURE) { + /* for procedure constants */ + expp->nd_class = Def; + } else expp->nd_class = Value; } @@ -686,7 +690,7 @@ ChkCall(expp) return ChkCast(expp); } - if (IsProcCall(left) || left->nd_type == error_type) { + if (IsProc(left) || left->nd_type == error_type) { /* A procedure call. It may also be a call to a standard procedure */ diff --git a/lang/m2/comp/code.c b/lang/m2/comp/code.c index d2be27d0e..19264fa0f 100644 --- a/lang/m2/comp/code.c +++ b/lang/m2/comp/code.c @@ -311,7 +311,7 @@ CodeCall(nd) and result is already done. */ register t_node *left = nd->nd_left; - register t_type *result_tp; + t_type *result_tp; int needs_fn; if (left->nd_type == std_type) { @@ -319,7 +319,7 @@ CodeCall(nd) return; } - assert(IsProcCall(left)); + assert(IsProc(left)); if (nd->nd_right) { CodeParameters(ParamList(left->nd_type), nd->nd_right); @@ -327,14 +327,19 @@ CodeCall(nd) switch(left->nd_class) { case Def: { - if (left->nd_def->df_kind & (D_PROCEDURE|D_PROCHEAD)) { - int level = left->nd_def->df_scope->sc_level; + register t_def *df = left->nd_def; + + if (df->df_kind == D_CONST) { + df = df->con_const.tk_data.tk_def; + } + if (df->df_kind & (D_PROCEDURE|D_PROCHEAD)) { + int level = df->df_scope->sc_level; if (level > 0) { C_lxl((arith) (proclevel - level)); } - needs_fn = left->nd_def->df_scope->sc_defmodule; - C_cal(NameOfProc(left->nd_def)); + needs_fn = df->df_scope->sc_defmodule; + C_cal(NameOfProc(df)); break; }} /* Fall through */ diff --git a/lang/m2/comp/em_m2.6 b/lang/m2/comp/em_m2.6 index 694b6f527..5975b4ef2 100644 --- a/lang/m2/comp/em_m2.6 +++ b/lang/m2/comp/em_m2.6 @@ -62,6 +62,9 @@ By default, warnings in class \fBO\fR and \fBW\fR are given. allow for warning messages whose class is a member of \fIclasses\fR. .IP \fB\-x\fR make all procedure names global, so that \fIadb\fR(1) understands them. +.IP \fB\-l\fR +enable local extensions. Currently, the only local extension consists of +procedure constants. .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/expression.g b/lang/m2/comp/expression.g index 9f8bf0dba..50eb4f6d3 100644 --- a/lang/m2/comp/expression.g +++ b/lang/m2/comp/expression.g @@ -85,7 +85,9 @@ ConstExpression(t_node **pnd;) DO_DEBUG(options['C'], PrNode(nd, 0)); if (ChkExpression(nd) && - ((nd)->nd_class != Set && (nd)->nd_class != Value)) { + nd->nd_class != Set && + nd->nd_class != Value && + ! (options['l'] && nd->nd_class == Def && IsProc(nd))) { error("constant expression expected"); } diff --git a/lang/m2/comp/main.c b/lang/m2/comp/main.c index a26733e98..0e30d6883 100644 --- a/lang/m2/comp/main.c +++ b/lang/m2/comp/main.c @@ -89,7 +89,7 @@ Compile(src, dst) InitTypes(); AddStandards(); #ifdef DEBUG - if (options['l']) { + if (options['t']) { LexScan(); return 1; } diff --git a/lang/m2/comp/node.H b/lang/m2/comp/node.H index b4b476f66..c8fffc501 100644 --- a/lang/m2/comp/node.H +++ b/lang/m2/comp/node.H @@ -56,4 +56,4 @@ extern t_node *MkNode(), *MkLeaf(), *dot2node(), *dot2leaf(); #define VALUE 010 #define IsCast(lnd) ((lnd)->nd_class == Def && is_type((lnd)->nd_def)) -#define IsProcCall(lnd) ((lnd)->nd_type->tp_fund == T_PROCEDURE) +#define IsProc(lnd) ((lnd)->nd_type->tp_fund == T_PROCEDURE) diff --git a/lang/m2/comp/options.c b/lang/m2/comp/options.c index 14c71e38b..cf199c8ac 100644 --- a/lang/m2/comp/options.c +++ b/lang/m2/comp/options.c @@ -56,6 +56,7 @@ DoOption(text) case 'x': /* every name global */ case 's': /* symmetric: MIN(INTEGER) = -MAX(INTEGER) */ case '3': /* strict 3rd edition Modula-2 */ + case 'l': /* local additions enabled */ options[text[-1]]++; break;