Added a local extension: procedure constants

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
 			*/

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 */

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

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");
 		  }
 

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;
 	}

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)

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;