fix: memory leak due to nested procedure definitions

check/extra/forcer.frm

@@ -19,7 +19,6 @@ L F =
 B ep;
 P;
 .end
-#pend_if valgrind?
 assert succeeded?
 assert result("F") =~ expr("
        + ep^-3 * ( 1/24 )
@@ -141,6 +140,7 @@ ModuleOption noparallel;
 B ep;
 P;
 .end
+# Too slow, but is supposed to pass.
 #pend_if valgrind?
 assert succeeded?
 assert result("F1") =~ expr("
@@ -269,6 +269,7 @@ ModuleOption noparallel;
 B ep;
 P;
 .end
+# Too slow, but is supposed to pass.
 #pend_if valgrind?
 assert succeeded?
 assert result("F1") =~ expr("
@@ -289,3 +290,219 @@ assert result("F2") =~ expr("
          z3 - 3705/8*z3^2
 ")
 *--#] Forcer_1-expand : 
+*--#[ Forcer_2 :
+* An easier version of the above, for checking with valgrind
+* timeout = 60 seconds.
+#include- forcer.h
+CF f,f1,f2,f3;
+V p2,p3;
+S x3;
+
+* Give 1 or -1. n1 is not used.
+Table randomsign(n1?);
+Fill randomsign() = random_(2)*2-3;
+
+* Zip two functions as:
+*   zip(f1,f2(p1,...,pN),f3(q1,...,qN)) -> f1(p1,q1,...,pN,qN),
+* for N >= 1.
+Table zip(f1?(?a1),f2?(p2?,?a2),f3?(p3?,?a3));
+Fill zip() =
+  + thetap_(nargs_(?a2,?a3)) * zip(f1(?a1,p2,p3),f2(?a2),f3(?a3))
+  + delta_(nargs_(?a2,?a3))  * f1(?a1,p2,p3)
+;
+
+* Element-wise multiplication as:
+*   emul(f1,f2(p1,...,pN),f3(a1,...,aN)) -> f1(p1*a1,...,pN*aN)
+* for N >= 1.
+Table emul(f1?(?a1),f2?(p2?,?a2),f3?(x3?,?a3));
+Fill emul() =
+  + thetap_(nargs_(?a2,?a3)) * emul(f1(?a1,p2*x3),f2(?a2),f3(?a3))
+  + delta_(nargs_(?a2,?a3))  * f1(?a1,p2*x3)
+;
+
+L F1 =
+  #do i=1,2
+    + Zno`i'(1,1,1,1,1,1,1,1,1,1,1,0,0,0)
+  #enddo
+;
+
+L F2 =
+  #do i=1,2
+    + Zno`i'(1,1,1,1,1,1,1,1,1,1,1,-1,0,0)
+    + Zno`i'(1,1,1,1,1,1,1,1,1,1,1,0,-1,0)
+    + Zno`i'(1,1,1,1,1,1,1,1,1,1,1,0,0,-1)
+  #enddo
+;
+
+id Zno1(n1?,...,n14?) =
+  +vx(-Q,p4,p5)
+  *vx(p3,-p4,p10)
+  *vx(p2,-p3,p9)
+  *vx(p1,-p2,p11)
+  *vx(-p5,p6,-p11)
+  *vx(-p6,p7,-p10)
+  *vx(-p7,p8,-p9)
+  *vx(-p1,-p8,Q)
+  /<p1.p1^n1>/.../<p11.p11^n11>
+  /p2.p4^n12/Q.p2^n13/Q.p3^n14
+;
+
+id Zno2(n1?,...,n14?) =
+  +vx(-Q,p4,p5)
+  *vx(p3,-p4,p11)
+  *vx(p6,p7,p10)
+  *vx(p2,-p3,-p10)
+  *vx(p1,-p2,p9)
+  *vx(-p5,-p6,-p9)
+  *vx(-p7,p8,-p11)
+  *vx(-p1,-p8,Q)
+  /<p1.p1^n1>/.../<p11.p11^n11>
+  /Q.p2^n12/p1.p4^n13/Q.p3^n14
+;
+
+id Zno3(n1?,...,n14?) =
+  +vx(-Q,p3,p4)
+  *vx(p6,p8,p10)
+  *vx(p5,-p10,p11)
+  *vx(p1,-p3,-p5)
+  *vx(-p4,-p8,p9)
+  *vx(p7,-p9,-p11)
+  *vx(p2,-p6,-p7)
+  *vx(-p1,-p2,Q)
+  /<p1.p1^n1>/.../<p11.p11^n11>
+  /Q.p6^n12/Q.p8^n13/p3.p6^n14
+;
+
+* Make a random permutation of the loop momenta. The result should be the same.
+multiply f1(p1,...,p11);
+multiply ranperm_(f2,p1,...,p11);
+multiply f3(<randomsign(1)>,...,<randomsign(11)>);
+id f2(?a)*f3(?b) = emul(f2,f2(?a),f3(?b));
+id f1(?a)*f2(?b) = zip(f1,f1(?a),f2(?b));
+id f1(?a) = replace_(?a);
+
+ModuleOption noparallel;
+.sort:input;
+
+#call Forcer(msbarexpand=4)
+B ep;
+P;
+.end
+assert succeeded?
+assert result("F1") =~ expr("
+       + ep^-1 * (  - 15*z5 )
+
+       + 21/2*z7 - 75/2*z6 + 55*z5 - 51*z3^2
+")
+assert result("F2") =~ expr("
+       + 161/2*z7 + 20*z5 + 18*z3^2
+")
+*--#] Forcer_2 : 
+*--#[ Forcer_2-expand :
+* An easier version of the above, for checking with valgrind
+* timeout = 60 seconds.
+#include- forcer.h
+CF f,f1,f2,f3;
+V p2,p3;
+S x3;
+
+* Give 1 or -1. n1 is not used.
+Table randomsign(n1?);
+Fill randomsign() = random_(2)*2-3;
+
+* Zip two functions as:
+*   zip(f1,f2(p1,...,pN),f3(q1,...,qN)) -> f1(p1,q1,...,pN,qN),
+* for N >= 1.
+Table zip(f1?(?a1),f2?(p2?,?a2),f3?(p3?,?a3));
+Fill zip() =
+  + thetap_(nargs_(?a2,?a3)) * zip(f1(?a1,p2,p3),f2(?a2),f3(?a3))
+  + delta_(nargs_(?a2,?a3))  * f1(?a1,p2,p3)
+;
+
+* Element-wise multiplication as:
+*   emul(f1,f2(p1,...,pN),f3(a1,...,aN)) -> f1(p1*a1,...,pN*aN)
+* for N >= 1.
+Table emul(f1?(?a1),f2?(p2?,?a2),f3?(x3?,?a3));
+Fill emul() =
+  + thetap_(nargs_(?a2,?a3)) * emul(f1(?a1,p2*x3),f2(?a2),f3(?a3))
+  + delta_(nargs_(?a2,?a3))  * f1(?a1,p2*x3)
+;
+
+L F1 =
+  #do i=1,2
+    + Zno`i'(1,1,1,1,1,1,1,1,1,1,1,0,0,0)
+  #enddo
+;
+
+L F2 =
+  #do i=1,2
+    + Zno`i'(1,1,1,1,1,1,1,1,1,1,1,-1,0,0)
+    + Zno`i'(1,1,1,1,1,1,1,1,1,1,1,0,-1,0)
+    + Zno`i'(1,1,1,1,1,1,1,1,1,1,1,0,0,-1)
+  #enddo
+;
+
+id Zno1(n1?,...,n14?) =
+  +vx(-Q,p4,p5)
+  *vx(p3,-p4,p10)
+  *vx(p2,-p3,p9)
+  *vx(p1,-p2,p11)
+  *vx(-p5,p6,-p11)
+  *vx(-p6,p7,-p10)
+  *vx(-p7,p8,-p9)
+  *vx(-p1,-p8,Q)
+  /<p1.p1^n1>/.../<p11.p11^n11>
+  /p2.p4^n12/Q.p2^n13/Q.p3^n14
+;
+
+id Zno2(n1?,...,n14?) =
+  +vx(-Q,p4,p5)
+  *vx(p3,-p4,p11)
+  *vx(p6,p7,p10)
+  *vx(p2,-p3,-p10)
+  *vx(p1,-p2,p9)
+  *vx(-p5,-p6,-p9)
+  *vx(-p7,p8,-p11)
+  *vx(-p1,-p8,Q)
+  /<p1.p1^n1>/.../<p11.p11^n11>
+  /Q.p2^n12/p1.p4^n13/Q.p3^n14
+;
+
+id Zno3(n1?,...,n14?) =
+  +vx(-Q,p3,p4)
+  *vx(p6,p8,p10)
+  *vx(p5,-p10,p11)
+  *vx(p1,-p3,-p5)
+  *vx(-p4,-p8,p9)
+  *vx(p7,-p9,-p11)
+  *vx(p2,-p6,-p7)
+  *vx(-p1,-p2,Q)
+  /<p1.p1^n1>/.../<p11.p11^n11>
+  /Q.p6^n12/Q.p8^n13/p3.p6^n14
+;
+
+* Make a random permutation of the loop momenta. The result should be the same.
+multiply f1(p1,...,p11);
+multiply ranperm_(f2,p1,...,p11);
+multiply f3(<randomsign(1)>,...,<randomsign(11)>);
+id f2(?a)*f3(?b) = emul(f2,f2(?a),f3(?b));
+id f1(?a)*f2(?b) = zip(f1,f1(?a),f2(?b));
+id f1(?a) = replace_(?a);
+
+ModuleOption noparallel;
+.sort:input;
+
+#call Forcer(msbarexpand=4,polyratfunexpand=15)
+B ep;
+P;
+.end
+assert succeeded?
+assert result("F1") =~ expr("
+       + ep^-1 * (  - 15*z5 )
+
+       + 21/2*z7 - 75/2*z6 + 55*z5 - 51*z3^2
+")
+assert result("F2") =~ expr("
+       + 161/2*z7 + 20*z5 + 18*z3^2
+")
+*--#] Forcer_2-expand : 

sources/execute.c

@@ -2428,13 +2428,12 @@ void UpdatePositions(void)
 			oldw = AS.Oldvflags;
 			AS.Oldvflags = (WORD *)Malloc1(NumExpressions*sizeof(WORD),"vflags pointers");
 			for ( i = 0; i < AS.NumOldNumFactors; i++ ) AS.Oldvflags[i] = oldw[i];
-			AS.NumOldNumFactors = NumExpressions;
 			M_free(oldw,"vflags pointers");
 			oldw = AS.Olduflags;
 			AS.Olduflags = (WORD *)Malloc1(NumExpressions*sizeof(WORD),"uflags pointers");
 			for ( i = 0; i < AS.NumOldNumFactors; i++ ) AS.Olduflags[i] = oldw[i];
-			AS.NumOldNumFactors = NumExpressions;
 			M_free(oldw,"uflags pointers");
+			AS.NumOldNumFactors = NumExpressions;
 		}
 		else {
 			AS.OldNumFactors = (WORD *)Malloc1(NumExpressions*sizeof(WORD),"numfactors pointers");

sources/pre.c

@@ -2569,6 +2569,7 @@ int DoCall(UBYTE *s)
 	for ( i = NumProcedures-1; i >= 0; i-- ) {
 		if ( StrCmp(Procedures[i].name,name) == 0 ) break;
 	}
+	// AP.ProcList.num = NumProcedures is incremented inside FromList
 	p = (PROCEDURE *)FromList(&AP.ProcList);
 	if ( i < 0 ) {	/* Try to find a file */
 		namesize = 0;
@@ -2584,6 +2585,7 @@ int DoCall(UBYTE *s)
 		while ( *v ) *t++ = *v++;
 		*t = 0;
 		p->loadmode = 0;	/* buffer should be freed at end */
+		p->mustfree = 1;
 		p->p.buffer = LoadInputFile(p->name,PROCEDUREFILE);
 		if ( p->p.buffer == 0 ) return(-1);
 		t[-4] = 0;
@@ -2592,6 +2594,7 @@ int DoCall(UBYTE *s)
 		p->p.buffer = Procedures[i].p.buffer;
 		p->name = Procedures[i].name;
 		p->loadmode = 1;
+		p->mustfree = 0; // this is just a copy of pointers to a permanently stored procedure
 	}
 	t = p->p.buffer;
 	SKIPBLANKS(t)
@@ -3352,9 +3355,10 @@ int DoEndprocedure(UBYTE *s)
 	if ( AP.PreSwitchModes[AP.PreSwitchLevel] != EXECUTINGPRESWITCH ) return(0);
 	if ( AP.PreIfStack[AP.PreIfLevel] != EXECUTINGIF ) return(0);
 	AC.CurrentStream = CloseStream(AC.CurrentStream);
+
 	do {
 		NumProcedures--;
-		if ( Procedures[NumProcedures].loadmode == 0 ) {
+		if ( Procedures[NumProcedures].mustfree == 1 ) {
 			M_free(Procedures[NumProcedures].p.buffer,"procedures buffer");
 			M_free(Procedures[NumProcedures].name,"procedures name");
 		}
@@ -4015,10 +4019,25 @@ int DoProcedure(UBYTE *s)
 		if ( PreSkip((UBYTE *)"procedure",(UBYTE *)"endprocedure",1) ) return(-1);
 		return(0);
 	}
+	// AP.ProcList.num = NumProcedures is incremented inside FromList
 	p = (PROCEDURE *)FromList(&AP.ProcList);
 	if ( PreLoad(&(p->p),(UBYTE *)"procedure",(UBYTE *)"endprocedure"
 		,1,(char *)"procedure") ) return(-1);
 
+	// If the procedure below is not local (loadmode 0) or has been called (loadmode 1), this is a
+	// nested procedure definition. We must free its allocations when we hit its DoEndprocedure.
+	// If it seems local (loadmode 2) but is tagged as "mustfree", it is multiply nested and we
+	// similarly must free its allocations.
+	if ( NumProcedures >= 2 &&
+		( Procedures[NumProcedures-2].loadmode != 2 || Procedures[NumProcedures-2].mustfree ) ) {
+		p->mustfree = 1;
+	}
+	// Otherwise, we are defining a local procedure at "ground level", and we keep the definition
+	// on the procedure stack until FORM terminates.
+	else {
+		p->mustfree = 0;
+	}
+
 	p->loadmode = 2;
 	s = p->p.buffer + 10;
 	while ( *s == ' ' || *s == LINEFEED ) s++;

sources/structs.h

@@ -884,6 +884,7 @@ typedef struct {
 	PRELOAD p;
 	UBYTE	*name;
 	int		loadmode;
+	int		mustfree;
 	PADPOINTER(0,1,0,0);
 } PROCEDURE;