Move some core procs into the (Tcl) stdlib extension

Also implement 'local' to declare/delete local procs
* Add tests/alias.test for testing alias, current, local
* proc now returns the name of the proc created
* Add helper 'function' to stdlib
Reimplement glob and case to use local procs
* This keeps these internal procs out of the global namespace

Signed-off-by: Steve Bennett <steveb@workware.net.au>

10 files changed, 350 insertions, 104 deletions

diff --git a/configure b/configure
index e43537b..819189e 100755
--- a/configure
+++ b/configure
@@ -3395,7 +3395,7 @@ if test "${enable_math+set}" = set; then :
 fi
 
 
-jim_extensions="load package readdir glob array clock exec file posix regexp signal tclcompat aio bio eventloop syslog"
+jim_extensions="stdlib load package readdir glob array clock exec file posix regexp signal tclcompat aio bio eventloop syslog"
 
 # Check whether --with-jim-ext was given.
 if test "${with_jim_ext+set}" = set; then :
diff --git a/configure.ac b/configure.ac
index 45f55ab..befc2b3 100644
--- a/configure.ac
+++ b/configure.ac
@@ -40,7 +40,7 @@ AC_ARG_ENABLE(math,
 	]
 )
 
-jim_extensions="load package readdir glob array clock exec file posix regexp signal tclcompat aio bio eventloop syslog"
+jim_extensions="stdlib load package readdir glob array clock exec file posix regexp signal tclcompat aio bio eventloop syslog"
 AC_ARG_WITH(jim-ext,
 	[  --with-jim-ext          specify jim extensions to build (or all, which is the default)],
 	[
diff --git a/glob.tcl b/glob.tcl
index 8288bc1..dbad26e 100644
--- a/glob.tcl
+++ b/glob.tcl
@@ -6,98 +6,100 @@
 # See LICENCE in this directory for full details.
 
 
-# If $dir is a directory, return a list of all entries
-# it contains which match $pattern
+# Implements the Tcl glob command
 #
-proc _glob_readdir_pattern {dir pattern} {
-	set result {}
+# Usage: glob ?-nocomplain? pattern ...
+#
+# Patterns use 'string match' (glob) pattern matching for each
+# directory level, plus support for braced alternations.
+#
+# e.g. glob "te[a-e]*/*.{c,tcl}"
+#
+# Note: files starting with . will only be returned if matching component
+#       of the pattern starts with .
+proc glob {args} {
 
-	# readdir doesn't return . or .., so simulate it here
-	if {$pattern in {. ..}} {
-		return $pattern
-	}
+	# If $dir is a directory, return a list of all entries
+	# it contains which match $pattern
+	#
+	local proc glob.readdir_pattern {dir pattern} {
+		set result {}
 
-	# Use -nocomplain here to return nothing if $dir is not a directory
-	foreach name [readdir -nocomplain $dir] {
-		if {[string match $pattern $name]} {
-			# Only include entries starting with . if the pattern starts with .
-			if {[string index $name 0] eq "." && [string index $pattern 0] ne "."} {
-				continue
-			}
-			lappend result $name
+		# readdir doesn't return . or .., so simulate it here
+		if {$pattern in {. ..}} {
+			return $pattern
 		}
-	}
 
-	return $result
-}
+		# Use -nocomplain here to return nothing if $dir is not a directory
+		foreach name [readdir -nocomplain $dir] {
+			if {[string match $pattern $name]} {
+				# Only include entries starting with . if the pattern starts with .
+				if {[string index $name 0] eq "." && [string index $pattern 0] ne "."} {
+					continue
+				}
+				lappend result $name
+			}
+		}
 
-# glob entries in directory $dir and pattern $rem
-#
-proc _glob_do {dir rem} {
-	# Take one level from rem
-	# Avoid regexp here
-	set i [string first / $rem]
-	if {$i < 0} {
-		set pattern $rem
-		set rempattern ""
-	} else {
-		set pattern [string range $rem 0 $i-1]
-		set rempattern [string range $rem $i+1 end]
+		return $result
 	}
 
-	# Determine the appropriate separator and globbing dir
-	set sep /
-	set globdir $dir
-	if {[string match "*/" $dir]} {
-		set sep ""
-	} elseif {$dir eq ""} {
-		set globdir .
-		set sep ""
-	}
+	# glob entries in directory $dir and pattern $rem
+	#
+	local proc glob.do {dir rem} {
+		# Take one level from rem
+		# Avoid regexp here
+		set i [string first / $rem]
+		if {$i < 0} {
+			set pattern $rem
+			set rempattern ""
+		} else {
+			set pattern [string range $rem 0 $i-1]
+			set rempattern [string range $rem $i+1 end]
+		}
 
-	set result {}
+		# Determine the appropriate separator and globbing dir
+		set sep /
+		set globdir $dir
+		if {[string match "*/" $dir]} {
+			set sep ""
+		} elseif {$dir eq ""} {
+			set globdir .
+			set sep ""
+		}
 
-	# If the pattern contains a braced expression, recursively call _glob_do
-	# to expand the alternations. Avoid regexp for dependency reasons.
-	# XXX: Doesn't handle backslashed braces
-	if {[set fb [string first "\{" $pattern]] >= 0} {
-		if {[set nb [string first "\}" $pattern $fb]] >= 0} {
-			set before [string range $pattern 0 $fb-1]
-			set braced [string range $pattern $fb+1 $nb-1]
-			set after [string range $pattern $nb+1 end]
-
-			foreach part [split $braced ,] {
-				lappend result {*}[_glob_do $dir $before$part$after]
+		set result {}
+
+		# If the pattern contains a braced expression, recursively call glob.do
+		# to expand the alternations. Avoid regexp for dependency reasons.
+		# XXX: Doesn't handle backslashed braces
+		if {[set fb [string first "\{" $pattern]] >= 0} {
+			if {[set nb [string first "\}" $pattern $fb]] >= 0} {
+				set before [string range $pattern 0 $fb-1]
+				set braced [string range $pattern $fb+1 $nb-1]
+				set after [string range $pattern $nb+1 end]
+
+				foreach part [split $braced ,] {
+					lappend result {*}[glob.do $dir $before$part$after]
+				}
+				return $result
 			}
-			return $result
 		}
-	}
 
-	# Use readdir and select all files which match the pattern
-	foreach f [_glob_readdir_pattern $globdir $pattern] {
-		if {$rempattern eq ""} {
-			# This is a terminal entry, so add it
-			lappend result $dir$sep$f
-		} else {
-			# Expany any entries at this level and add them
-			lappend result {*}[_glob_do $dir$sep$f $rempattern]
+		# Use readdir and select all files which match the pattern
+		foreach f [glob.readdir_pattern $globdir $pattern] {
+			if {$rempattern eq ""} {
+				# This is a terminal entry, so add it
+				lappend result $dir$sep$f
+			} else {
+				# Expany any entries at this level and add them
+				lappend result {*}[glob.do $dir$sep$f $rempattern]
+			}
 		}
+		return $result
 	}
-	return $result
-}
 
-# Implements the Tcl glob command
-#
-# Usage: glob ?-nocomplain? pattern ...
-#
-# Patterns use 'string match' (glob) pattern matching for each
-# directory level, plus support for braced alternations.
-#
-# e.g. glob "te[a-e]*/*.{c,tcl}"
-#
-# Note: files starting with . will only be returned if matching component
-#       of the pattern starts with .
-proc glob {args} {
+	# Start of main glob
 	set nocomplain 0
 
 	if {[lindex $args 0] eq "-nocomplain"} {
@@ -110,9 +112,9 @@ proc glob {args} {
 		if {$pattern eq "/"} {
 			lappend result /
 		} elseif {[string match "/*" $pattern]} {
-			lappend result {*}[_glob_do / [string range $pattern 1 end]]
+			lappend result {*}[glob.do / [string range $pattern 1 end]]
 		} else {
-			lappend result {*}[_glob_do "" $pattern]
+			lappend result {*}[glob.do "" $pattern]
 		}
 	}
 
diff --git a/jim.c b/jim.c
index 3ee76e9..f13a4b6 100644
--- a/jim.c
+++ b/jim.c
@@ -115,6 +115,7 @@ static int ListSetIndex(Jim_Interp *interp, Jim_Obj *listPtr, int index, Jim_Obj
 static Jim_Obj *Jim_ExpandDictSugar(Jim_Interp *interp, Jim_Obj *objPtr);
 static void SetDictSubstFromAny(Jim_Interp *interp, Jim_Obj *objPtr);
 static void JimSetFailedEnumResult(Jim_Interp *interp, const char *arg, const char *badtype, const char *prefix, const char * const *tablePtr, const char *name);
+static void JimDeleteLocalProcs(Jim_Interp *interp);
 
 static const Jim_HashTableType JimVariablesHashTableType;
 
@@ -3229,6 +3230,9 @@ int Jim_CreateProcedure(Jim_Interp *interp, const char *cmdName,
      * can never affect existing cached commands. We don't do
      * negative caching. */
     Jim_AddHashEntry(&interp->commands, cmdName, cmdPtr);
+
+    /* Unlike Tcl, set the name of the proc as the result */
+    Jim_SetResultString(interp, cmdName, -1);
     return JIM_OK;
 
 err:
@@ -4399,6 +4403,7 @@ Jim_Interp *Jim_CreateInterp(void)
     i->sigmask = 0;
     i->signal_level = 0;
     i->signal_set_result = NULL;
+    i->localProcs = NULL;
 
     /* Note that we can create objects only after the
      * interpreter liveList and freeList pointers are
@@ -4456,6 +4461,8 @@ void Jim_FreeInterp(Jim_Interp *i)
     Jim_FreeHashTable(&i->assocData);
     Jim_FreeHashTable(&i->packages);
     Jim_Free(i->prngState);
+    JimDeleteLocalProcs(i);
+
     /* Free the call frames list */
     while(cf) {
         prevcf = cf->parentCallFrame;
@@ -8881,6 +8888,22 @@ static void JimAddErrorToStack(Jim_Interp *interp, int retcode, const char *file
     }
 }
 
+/* And delete any local procs */
+static void JimDeleteLocalProcs(Jim_Interp *interp)
+{
+    if (interp->localProcs) {
+        char *procname;
+
+        while ((procname = Jim_StackPop(interp->localProcs)) != NULL) {
+            Jim_DeleteCommand(interp, procname);
+            Jim_Free(procname);
+        }
+        Jim_FreeStack(interp->localProcs);
+        Jim_Free(interp->localProcs);
+        interp->localProcs = NULL;
+    }
+}
+
 int Jim_EvalObj(Jim_Interp *interp, Jim_Obj *scriptObjPtr)
 {
     int i, j = 0, len;
@@ -9107,6 +9130,7 @@ err:
     }
     if (argv != sargv)
         Jim_Free(argv);
+
     return retcode;
 }
 
@@ -9125,6 +9149,7 @@ int JimCallProcedure(Jim_Interp *interp, Jim_Cmd *cmd, int argc,
     Jim_CallFrame *callFramePtr;
     Jim_Obj *argObjPtr;
     Jim_Obj *procname = argv[0];
+    Jim_Stack *prevLocalProcs;
 
     /* Check arity */
     if (argc - 1 < cmd->leftArity + cmd->rightArity ||
@@ -9239,9 +9264,17 @@ int JimCallProcedure(Jim_Interp *interp, Jim_Cmd *cmd, int argc,
         Jim_SetVariable(interp, argObjPtr, *argv++);
     }
 
+    /* Install a new stack for local procs */
+    prevLocalProcs = interp->localProcs;
+    interp->localProcs = NULL;
+
     /* Eval the body */
     retcode = Jim_EvalObj(interp, cmd->bodyObjPtr);
 
+    /* Delete any local procs */
+    JimDeleteLocalProcs(interp);
+    interp->localProcs = prevLocalProcs;
+
     /* Destroy the callframe */
     interp->numLevels --;
     interp->framePtr = interp->framePtr->parentCallFrame;
@@ -9362,6 +9395,7 @@ int Jim_EvalFile(Jim_Interp *interp, const char *filename)
     char *buf;
     Jim_Obj *scriptObjPtr;
     Jim_Obj *prevScriptObj;
+    Jim_Stack *prevLocalProcs;
     struct stat sb;
     int retcode;
     int readlen;
@@ -9391,8 +9425,16 @@ int Jim_EvalFile(Jim_Interp *interp, const char *filename)
     prevScriptObj = interp->currentScriptObj;
     interp->currentScriptObj = scriptObjPtr;
 
+    /* Install a new stack for local procs */
+    prevLocalProcs = interp->localProcs;
+    interp->localProcs = NULL;
+
     retcode = Jim_EvalObj(interp, scriptObjPtr);
 
+    /* Delete any local procs */
+    JimDeleteLocalProcs(interp);
+    interp->localProcs = prevLocalProcs;
+
     /* Handle the JIM_RETURN return code */
     if (retcode == JIM_RETURN) {
         if (--interp->returnLevel <= 0) {
@@ -11147,17 +11189,28 @@ static int Jim_EvalCoreCommand(Jim_Interp *interp, int argc,
         Jim_Obj *const *argv)
 {
     int rc;
+    Jim_Stack *prevLocalProcs;
 
     if (argc < 2) {
         Jim_WrongNumArgs(interp, 1, argv, "script ?...?");
         return JIM_ERR;
     }
+
+    /* Install a new stack for local procs */
+    prevLocalProcs = interp->localProcs;
+    interp->localProcs = NULL;
+
     if (argc == 2) {
         rc = Jim_EvalObj(interp, argv[1]);
     }
     else {
         rc = Jim_EvalObj(interp, Jim_ConcatObj(interp, argc-1, argv+1));
     }
+
+    /* Delete any local procs */
+    JimDeleteLocalProcs(interp);
+    interp->localProcs = prevLocalProcs;
+
     if (rc == JIM_ERR) {
         /* eval is "interesting", so add a stack frame here */
         interp->addStackTrace++;
@@ -11402,6 +11455,31 @@ static int Jim_ProcCoreCommand(Jim_Interp *interp, int argc,
     }
 }
 
+/* [local] */
+static int Jim_LocalCoreCommand(Jim_Interp *interp, int argc,
+        Jim_Obj *const *argv)
+{
+    /* Evaluate the arguments */
+    int retcode = Jim_EvalObjVector(interp, argc - 1, argv + 1);
+
+    /* If OK, and the result is a proc, add it to the list of local procs */
+    if (retcode == 0) {
+        const char *procname = Jim_GetString(Jim_GetResult(interp), NULL);
+        if (Jim_FindHashEntry(&interp->commands, procname) == NULL) {
+            Jim_SetResultFormatted(interp, "not a proc: \"%s\"", procname);
+            return JIM_ERR;
+        }
+        if (interp->localProcs == NULL) {
+            interp->localProcs = Jim_Alloc(sizeof(*interp->localProcs));
+            Jim_InitStack(interp->localProcs);
+        }
+        Jim_StackPush(interp->localProcs, Jim_StrDup(procname));
+    }
+
+    return retcode;
+}
+
+
 /* [concat] */
 static int Jim_ConcatCoreCommand(Jim_Interp *interp, int argc, 
         Jim_Obj *const *argv)
@@ -12823,26 +12901,10 @@ static const struct {
     {"range", Jim_RangeCoreCommand},
     {"rand", Jim_RandCoreCommand},
     {"tailcall", Jim_TailcallCoreCommand},
+    {"local", Jim_LocalCoreCommand},
     {NULL, NULL},
 };
 
-/* Some Jim core command is actually a procedure written in Jim itself. */
-static void Jim_RegisterCoreProcedures(Jim_Interp *interp)
-{
-#ifdef JIM_REFERENCES
-    Jim_Eval(interp, 
-"proc lambda {arglist args} {\n"
-"    set name [ref {} function lambdaFinalizer]\n"
-"    uplevel 1 [list proc $name $arglist {expand}$args]\n"
-"    return $name\n"
-"}\n"
-"proc lambdaFinalizer {name val} {\n"
-"    rename $name {}\n"
-"}\n"
-    );
-#endif
-}
-
 void Jim_RegisterCoreCommands(Jim_Interp *interp)
 {
     int i = 0;
@@ -12854,7 +12916,6 @@ void Jim_RegisterCoreCommands(Jim_Interp *interp)
                 NULL, NULL);
         i++;
     }
-    Jim_RegisterCoreProcedures(interp);
 }
 
 /* -----------------------------------------------------------------------------
diff --git a/jim.h.in b/jim.h.in
index a9fc9d4..a02a045 100644
--- a/jim.h.in
+++ b/jim.h.in
@@ -541,6 +541,7 @@ typedef struct Jim_Interp {
     struct Jim_HashTable assocData; /* per-interp storage for use by packages */
     Jim_PrngState *prngState; /* per interpreter Random Number Gen. state. */
     struct Jim_HashTable packages; /* Provided packages hash table */
+    Jim_Stack *localProcs; /* procs to be destroyed on end of evaluation */
 } Jim_Interp;
 
 /* Currently provided as macro that performs the increment.
diff --git a/stdlib.tcl b/stdlib.tcl
new file mode 100644
index 0000000..e406a4f
--- /dev/null
+++ b/stdlib.tcl
@@ -0,0 +1,40 @@
+# Create a single word alias (proc) for one or more words
+# e.g. alias x info exists
+# if {[x var]} ...
+proc alias {name args} {
+	set prefix $args
+	proc $name args prefix {
+		uplevel 1 $prefix $args
+	}
+}
+
+# Creates an anonymous procedure
+proc lambda {arglist args} {
+	set name [ref {} function lambda.finalizer]
+	uplevel 1 [list proc $name $arglist {*}$args]
+	return $name
+}
+
+proc lambda.finalizer {name val} {
+	rename $name {}
+}
+
+# Like alias, but creates and returns an anonyous procedure
+proc curry {args} {
+	set prefix $args
+	lambda args prefix {
+		uplevel 1 $prefix $args
+	}
+}
+
+# Returns the given argument.
+# Useful with 'local' as follows:
+#   proc a {} {...}
+#   local function a 
+#
+#   set x [lambda ...]
+#   local function $x
+#
+proc function {value} {
+	return $value
+}
diff --git a/tclcompat.tcl b/tclcompat.tcl
index b631ae0..58dee97 100644
--- a/tclcompat.tcl
+++ b/tclcompat.tcl
@@ -34,20 +34,20 @@ proc case {var args} {
 	}
 
 	# Internal function to match a value agains a list of patterns
-	set checker [lambda {value pattern} {string match $pattern $value}]
+	local proc case.checker {value pattern} {
+		string match $pattern $value
+	}
 
 	foreach {value action} $args {
 		if {$value eq "default"} {
 			set do_action $action
 			continue
-		} elseif {[lsearch -bool -command $checker $value $var]} {
+		} elseif {[lsearch -bool -command case.checker $value $var]} {
 			set do_action $action
 			break
 		}
 	}
 
-	rename $checker ""
-
 	if {[info exists do_action]} {
 		set rc [catch [list uplevel 1 $do_action] result opts]
 		if {$rc} {
@@ -214,5 +214,4 @@ proc throw {code {msg ""}} {
 	return -code $code $msg
 }
 
-
 set ::tcl_platform(platform) unix
diff --git a/tests/alias.test b/tests/alias.test
new file mode 100644
index 0000000..94aa4f1
--- /dev/null
+++ b/tests/alias.test
@@ -0,0 +1,123 @@
+source testing.tcl
+
+test alias-1.1 "One word alias" {
+	set x 2
+	alias newincr incr
+	newincr x 
+} {3}
+
+test alias-1.4 "Two word alias" {
+	alias infoexists info exists
+	infoexists x
+} {1}
+
+test alias-1.5 "Replace alias" {
+	alias newincr infoexists
+	newincr x
+} {1}
+
+test alias-1.6 "Delete alias" {
+	rename newincr ""
+	catch {newincr x}
+} {1}
+
+test alias-1.7 "Replace alias with proc" {
+	proc infoexists {n} {
+		return yes
+	}
+	infoexists any
+} {yes}
+
+test alias-1.8 "Replace proc with alias" {
+	alias infoexists info exists
+	infoexists any
+} {0}
+
+test curry-1.1 "One word curry" {
+	set x 2
+	set one [curry incr]
+	$one x 
+} {3}
+
+test curry-1.4 "Two word curry" {
+	set two [curry info exists]
+	list [$two x] [$two y]
+} {1 0}
+
+test curry-1.5 "Delete curry" {
+	unset one two
+	collect
+} {2}
+
+test local-1.1 "local lambda in eval" {
+	set x 1
+	eval {
+		local set a [lambda {b} { incr b }]
+		set x [$a $x]
+	}
+	list [info procs $a] $x
+} {{} 2}
+
+test local-1.2 "local curry in proc" {
+	proc a {} {
+		local set p [curry info exists]
+		set x 1
+		list $p [$p x] [$p y]
+	}
+	lassign [a] p exists_x exists_y
+	list [info procs $p] $exists_x $exists_y
+} {{} 1 0}
+
+test local-1.2 "set local curry in proc" {
+	proc a {} {
+		set p [local curry info exists]
+		set x 1
+		list $p [$p x] [$p y]
+	}
+	lassign [a] p exists_x exists_y
+	list [info procs $p] $exists_x $exists_y
+} {{} 1 0}
+
+test local-1.3 "local alias in proc" {
+	proc a {} {
+		local alias p info exists
+		set x 1
+		list [p x] [p y]
+	}
+	lassign [a] exists_x exists_y
+	list [info procs p] $exists_x $exists_y
+} {{} 1 0}
+
+test local-1.5 "local proc in proc" {
+	set ::x 1
+	proc a {} {
+		local proc b {} { incr ::x }
+		b
+		set ::x
+	}
+	a
+	list [info procs b] $::x
+} {{} 2}
+
+test local-1.6 "local lambda in lsort" {
+	lsort -command [local lambda {a b} {string compare $a $b}] {d a f g}
+} {a d f g}
+
+test local-1.7 "check no reference procs" {
+	info procs "<reference*"
+} {}
+
+test local-1.8 "local on non-proc" {
+	list [catch {local set x blah} msg] $msg
+} {1 {not a proc: "blah"}}
+
+test local-1.9 "local on existing proc" {
+	eval {
+		proc a {b} {incr b}
+		local function a
+		set c [lambda b {incr b -1}]
+		local function $c
+		lappend result [a 1] [$c 2]
+	}
+	list [info procs a] $result 
+} {{} {2 1}}
diff --git a/tests/case.test b/tests/case.test
index 4a594ad..a774004 100644
--- a/tests/case.test
+++ b/tests/case.test
@@ -1,5 +1,25 @@
 source testing.tcl
 
+test case-1.1 "Simple case" {
+	foreach c {abc xyz def sdfbc basdf a aba} {
+		case $c in {
+			b* {
+				lappend result 1
+			}
+			{ab a} {
+				lappend result 2
+			}
+			{def *bc} {
+				lappend result 3
+			}
+			default {
+				lappend result 4
+			}
+		}
+	}
+	set result 
+} {3 4 3 3 1 2 4}
+
 # case is a proc, but it should be able
 # to cause a return in do_case
 proc do_case {var} {
diff --git a/tests/proc.test b/tests/proc.test
index 56ed59a..985f68b 100644
--- a/tests/proc.test
+++ b/tests/proc.test
@@ -30,7 +30,7 @@ proc tproc x {
 test proc-old-1.2 {simple procedure call and return} {tproc 2} 3
 test proc-old-1.3 {simple procedure call and return} {
     proc tproc {} {return foo}
-} {}
+} {tproc}
 test proc-old-1.4 {simple procedure call and return} {
     proc tproc {} {return}
     tproc