Added a local extension: procedure constants

diff --git a/lang/m2/comp/chk_expr.c b/lang/m2/comp/chk_expr.c
index 696cadc..6c70cb1 100644 (file)
--- 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 d2be27d..19264fa 100644 (file)
--- 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 694b6f5..5975b4e 100644 (file)
--- 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 9f8bf0d..50eb4f6 100644 (file)
--- 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 a26733e..0e30d68 100644 (file)
--- 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 b4b476f..c8fffc5 100644 (file)
--- 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 14c71e3..cf199c8 100644 (file)
--- 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;