* tests/compile.test: new tests for [Bug 467523]

2 files changed, 57 insertions, 2 deletions

diff --git a/ChangeLog b/ChangeLog
index 5d6b7c9..fc790fd 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2001-10-12  Miguel Sofer  <msofer@users.sourceforge.net>
+	
+	* tests/compile.test: new tests for [Bug 467523]; they are only
+	effective if TCL_MEM_DEBUG was set during compilation.
+
 2001-10-11  Miguel Sofer  <msofer@users.sourceforge.net>
 	
 	* generic/tclLiteral.c: (TclReleaseLiteral) insured that
diff --git a/tests/compile.test b/tests/compile.test
index 5e81a5c..ae3bfd4 100644
--- a/tests/compile.test
+++ b/tests/compile.test
@@ -1,4 +1,5 @@
-# This file contains tests for the files tclCompile.c and tclCompCmds.c
+# This file contains tests for the files tclCompile.c, tclCompCmds.c
+# and tclLiteral.c
 #
 # This file contains a collection of tests for one or more of the Tcl
 # built-in commands.  Sourcing this file into Tcl runs the tests and
@@ -10,7 +11,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: compile.test,v 1.11 2001/08/31 17:53:57 hobbs Exp $
+# RCS: @(#) $Id: compile.test,v 1.12 2001/10/12 16:13:32 msofer Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest
@@ -239,6 +240,55 @@ test compile-11.9 {Tcl_Append*: ensure Tcl_ResetResult is used properly} {
     list [catch {p} msg] $msg
 } {1 {unmatched open brace in list}}
 
+# 
+# Special section for tests of tclLiteral.c
+# The following tests check for incorrect memory handling in
+# TclReleaseLiteral. They are only effective when tcl is compiled 
+# with TCL_MEM_DEBUG
+#
+# Special test for leak on interp delete [Bug 467523]. 
+test compile-12.1 {testing literal leak on interp delete} {
+    if {[llength [info commands memory]]} {
+	proc getbytes {} {
+	    set lines [split [memory info] "\n"]
+	    lindex [lindex $lines 3] 3
+	}
+	
+	set end [getbytes]
+	for {set i 0} {$i < 5} {incr i} {
+	    interp create foo 
+	    foo eval { 
+		namespace eval bar {}
+	    } 
+	    interp delete foo
+	    set tmp $end
+	    set end [getbytes]
+	}
+
+	set leak [expr {$end - $tmp}]
+	rename getbytes {}
+    } else {
+	set leak 0
+    }
+    set leak
+} 0
+# Special test for a memory error in a preliminary fix of [Bug 467523]. 
+# It requires executing a helpfile
+test compile-12.2 {testing error on literal deletion} {
+    makeFile {
+	for {set i 0} {$i < 5} {incr i} {
+	    namespace eval bar {}
+	    namespace delete bar
+	}
+	puts 0
+    } source.file
+    set res [catch {
+	exec [info nameofexecutable] source.file 
+    }]
+    catch {::tcltest::removeFile source.file}
+    set res
+} 0
+
 # cleanup
 catch {rename p ""}
 catch {namespace delete test_ns_compile}